45 lines
1.4 KiB
Mathematica
45 lines
1.4 KiB
Mathematica
ALPBOP ;OIFO-DALLAS/SED/KC/FOXK BCMA-BCBU PURGE OLD ORDERS ;5/2/2002
|
|
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
|
|
;
|
|
ST ;Start here. Purge Order information based of stop date first
|
|
;Get the parameter setting for number of days to hold patient
|
|
;orders. Default is 7 days
|
|
D NOW^%DTC
|
|
S X1=X
|
|
S X2="-"_$$DEFOR^ALPBUTL3()
|
|
D C^%DTC S ALPPUR=X K X1,X2
|
|
S ALPPUR=X
|
|
D WAIT^DICD
|
|
S ALPDFN=0
|
|
F S ALPDFN=$O(^ALPB(53.7,ALPDFN)) Q:+ALPDFN'>0 D
|
|
. S ALPBIEN=0
|
|
. F S ALPBIEN=$O(^ALPB(53.7,ALPDFN,2,ALPBIEN)) Q:+ALPBIEN'>0 D
|
|
. . ;First look for Stop Date
|
|
. . S ALPBDATE=+$P($G(^ALPB(53.7,ALPDFN,2,ALPBIEN,1)),U,2)
|
|
. . ;If stop date is not there then use last updated date
|
|
. . S:+ALPBDATE'>0 ALPBDATE=+$P(^ALPB(53.7,ALPDFN,2,ALPBIEN,0),U,4)
|
|
. . Q:ALPBDATE>ALPPUR
|
|
. . K DIK,DA
|
|
. . S DA(1)=ALPDFN,DA=ALPBIEN
|
|
. . S DIK="^ALPB(53.7,"_DA(1)_",2," D ^DIK
|
|
. ;Now check to see if I need to remove the patient record
|
|
. D NOW^%DTC
|
|
. S X1=X
|
|
. ;Get the parameter setting for number of days to hold patient record
|
|
. ;Default is 30 days with no order information
|
|
. S X2="-"_$$DEFPR^ALPBUTL3()
|
|
. D C^%DTC S ALPPUR=X K X1,X2
|
|
. S ALPPUR=X
|
|
. S ALPBDATE=+$P(^ALPB(53.7,ALPDFN,0),U,8)
|
|
. ;Quit if record had been updated within time frame
|
|
. Q:ALPBDATE>ALPPUR
|
|
. I '$D(^ALPB(53.7,ALPDFN,2)) D RPAT Q
|
|
. I +$O(^ALPB(53.7,ALPDFN,2,0))'>0 D RPAT
|
|
STOP K ALPBIEN,ALPDFN,DA,ALPBDATE,ALPPUR,DR,DIE,X,DIK,X1,X2
|
|
Q
|
|
RPAT ;Remove patient
|
|
K DIK
|
|
S DA=ALPDFN
|
|
S DIK="^ALPB(53.7," D ^DIK
|
|
Q
|