| [613] | 1 | ALPBOP ;OIFO-DALLAS/SED/KC/FOXK BCMA-BCBU PURGE OLD ORDERS ;5/2/2002
|
|---|
| 2 | ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
|
|---|
| 3 | ;
|
|---|
| 4 | ST ;Start here. Purge Order information based of stop date first
|
|---|
| 5 | ;Get the parameter setting for number of days to hold patient
|
|---|
| 6 | ;orders. Default is 7 days
|
|---|
| 7 | D NOW^%DTC
|
|---|
| 8 | S X1=X
|
|---|
| 9 | S X2="-"_$$DEFOR^ALPBUTL3()
|
|---|
| 10 | D C^%DTC S ALPPUR=X K X1,X2
|
|---|
| 11 | S ALPPUR=X
|
|---|
| 12 | D WAIT^DICD
|
|---|
| 13 | S ALPDFN=0
|
|---|
| 14 | F S ALPDFN=$O(^ALPB(53.7,ALPDFN)) Q:+ALPDFN'>0 D
|
|---|
| 15 | . S ALPBIEN=0
|
|---|
| 16 | . F S ALPBIEN=$O(^ALPB(53.7,ALPDFN,2,ALPBIEN)) Q:+ALPBIEN'>0 D
|
|---|
| 17 | . . ;First look for Stop Date
|
|---|
| 18 | . . S ALPBDATE=+$P($G(^ALPB(53.7,ALPDFN,2,ALPBIEN,1)),U,2)
|
|---|
| 19 | . . ;If stop date is not there then use last updated date
|
|---|
| 20 | . . S:+ALPBDATE'>0 ALPBDATE=+$P(^ALPB(53.7,ALPDFN,2,ALPBIEN,0),U,4)
|
|---|
| 21 | . . Q:ALPBDATE>ALPPUR
|
|---|
| 22 | . . K DIK,DA
|
|---|
| 23 | . . S DA(1)=ALPDFN,DA=ALPBIEN
|
|---|
| 24 | . . S DIK="^ALPB(53.7,"_DA(1)_",2," D ^DIK
|
|---|
| 25 | . ;Now check to see if I need to remove the patient record
|
|---|
| 26 | . D NOW^%DTC
|
|---|
| 27 | . S X1=X
|
|---|
| 28 | . ;Get the parameter setting for number of days to hold patient record
|
|---|
| 29 | . ;Default is 30 days with no order information
|
|---|
| 30 | . S X2="-"_$$DEFPR^ALPBUTL3()
|
|---|
| 31 | . D C^%DTC S ALPPUR=X K X1,X2
|
|---|
| 32 | . S ALPPUR=X
|
|---|
| 33 | . S ALPBDATE=+$P(^ALPB(53.7,ALPDFN,0),U,8)
|
|---|
| 34 | . ;Quit if record had been updated within time frame
|
|---|
| 35 | . Q:ALPBDATE>ALPPUR
|
|---|
| 36 | . I '$D(^ALPB(53.7,ALPDFN,2)) D RPAT Q
|
|---|
| 37 | . I +$O(^ALPB(53.7,ALPDFN,2,0))'>0 D RPAT
|
|---|
| 38 | STOP K ALPBIEN,ALPDFN,DA,ALPBDATE,ALPPUR,DR,DIE,X,DIK,X1,X2
|
|---|
| 39 | Q
|
|---|
| 40 | RPAT ;Remove patient
|
|---|
| 41 | K DIK
|
|---|
| 42 | S DA=ALPDFN
|
|---|
| 43 | S DIK="^ALPB(53.7," D ^DIK
|
|---|
| 44 | Q
|
|---|
