- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBOP 1512 printed Feb 18, 2025@23:05:51 Page 2
- ALPBOP ;OIFO-DALLAS/SED/KC/FOXK BCMA-BCBU PURGE OLD ORDERS ;5/2/2002
- +1 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
- +2 ;
- ST ;Start here. Purge Order information based of stop date first
- +1 ;Get the parameter setting for number of days to hold patient
- +2 ;orders. Default is 7 days
- +3 DO NOW^%DTC
- +4 SET X1=X
- +5 SET X2="-"_$$DEFOR^ALPBUTL3()
- +6 DO C^%DTC
- SET ALPPUR=X
- KILL X1,X2
- +7 SET ALPPUR=X
- +8 DO WAIT^DICD
- +9 SET ALPDFN=0
- +10 FOR
- SET ALPDFN=$ORDER(^ALPB(53.7,ALPDFN))
- if +ALPDFN'>0
- QUIT
- Begin DoDot:1
- +11 SET ALPBIEN=0
- +12 FOR
- SET ALPBIEN=$ORDER(^ALPB(53.7,ALPDFN,2,ALPBIEN))
- if +ALPBIEN'>0
- QUIT
- Begin DoDot:2
- +13 ;First look for Stop Date
- +14 SET ALPBDATE=+$PIECE($GET(^ALPB(53.7,ALPDFN,2,ALPBIEN,1)),U,2)
- +15 ;If stop date is not there then use last updated date
- +16 if +ALPBDATE'>0
- SET ALPBDATE=+$PIECE(^ALPB(53.7,ALPDFN,2,ALPBIEN,0),U,4)
- +17 if ALPBDATE>ALPPUR
- QUIT
- +18 KILL DIK,DA
- +19 SET DA(1)=ALPDFN
- SET DA=ALPBIEN
- +20 SET DIK="^ALPB(53.7,"_DA(1)_",2,"
- DO ^DIK
- End DoDot:2
- +21 ;Now check to see if I need to remove the patient record
- +22 DO NOW^%DTC
- +23 SET X1=X
- +24 ;Get the parameter setting for number of days to hold patient record
- +25 ;Default is 30 days with no order information
- +26 SET X2="-"_$$DEFPR^ALPBUTL3()
- +27 DO C^%DTC
- SET ALPPUR=X
- KILL X1,X2
- +28 SET ALPPUR=X
- +29 SET ALPBDATE=+$PIECE(^ALPB(53.7,ALPDFN,0),U,8)
- +30 ;Quit if record had been updated within time frame
- +31 if ALPBDATE>ALPPUR
- QUIT
- +32 IF '$DATA(^ALPB(53.7,ALPDFN,2))
- DO RPAT
- QUIT
- +33 IF +$ORDER(^ALPB(53.7,ALPDFN,2,0))'>0
- DO RPAT
- End DoDot:1
- STOP KILL ALPBIEN,ALPDFN,DA,ALPBDATE,ALPPUR,DR,DIE,X,DIK,X1,X2
- +1 QUIT
- RPAT ;Remove patient
- +1 KILL DIK
- +2 SET DA=ALPDFN
- +3 SET DIK="^ALPB(53.7,"
- DO ^DIK
- +4 QUIT
