- PSGPLPRG ;BIR/CML3-PURGE PICK LISTS ;20 JUL 94 / 5:46 PM
- ;;5.0; INPATIENT MEDICATIONS ;**5**;16 DEC 97
- AP ;
- D ENCV^PSGSETU I $D(XQUIT) Q
- S ND=$P($G(^PS(59.7,1,63.5)),"^",1,3) I $P(ND,"^",2) S PSGOD=$$ENDTC^PSGMI($P(ND,"^",2))
- W !!?$S('$P(ND,"^",2):24,ND:13,1:17),"** AUTO PURGE ",$S(ND=""!(ND="^^"):"NEVER STARTED.",ND:"SET TO "_+ND_" DAYS",1:"STOPPED") W:$P(ND,"^",2) ", AS OF ",PSGOD W " **",!
- ;
- DA ;
- S Y=-1,%DT="EPTX" F R !!,"Enter PURGE STOP DATE: ",X:DTIME W:'$T $C(7) S:'$T X="^" D DAM:X?1."?",^%DT:"^"'[X I Y>0!("^"[X) W:Y'>0 !,$C(7),"No date selected for purge run." Q
- K %DT I Y>0 S PSGPLPD=Y K ZTSAVE S PSGTID=$H,PSGTIR="ENQ^PSGPLPRG",ZTSAVE("PSGPLPD")="",ZTDESC="PICK LIST PURGE",ZTIO="" D ENNOIO^PSGTI W:$D(ZTSK) !,"Pick list purge queued!"
- G DONE
- ;
- DAM ;
- W !!," If a date is entered here, all of the FILED AWAY PICK LISTS that started ",!,"before the entered date will be deleted." Q
- ;
- ENQ ;
- F Q=0:0 S Q=$O(^PS(53.5,"AO",Q)) Q:'Q D
- .F QQ=0:0 S QQ=$O(^PS(53.5,"AO",Q,QQ)) Q:'QQ!(QQ>PSGPLPD) D
- ..F PLN=0:0 S PLN=$O(^PS(53.5,"AO",Q,QQ,PLN)) Q:'PLN D
- ...K DA,DIK S DIK="^PS(53.5,",DA=PLN D ^DIK K ^PS(53.5,PLN)
- ...I $D(^PS(53.55,PLN)) K DA,DIK S DIK="^PS(53.55,",DA=PLN D ^DIK K ^PS(53.55,PLN)
- ;
- DONE ;
- D ENKV^PSGSETU K AM,ND,PLN,PSGPLPD,ST Q
- ;
- ENASK ; sets, resets, or deletes auto purge (# of days)
- D ENCV^PSGSETU I $D(XQUIT) Q
- D NOW^%DTC S PSGDT=% S ND=$P($G(^PS(59.7,1,63.5)),"^",1,3)
- F W !!,"DAYS 'FILED AWAY' PICK LISTS SHOULD LAST",$S(+ND:" "_+ND_"// ",1:": ") R X:DTIME Q:"^"[X!(X?1.2N&(X>0)&(X<91)) D QUES:X?1."?",KILL:X="@" Q:X="@" W:X'?1."?" $C(7)," ??"
- I X,X'=+ND W:'ND " (AUTO PURGE WILL ",$P("^RE","^",ND]""+1),"START.)" S $P(^PS(59.7,1,63.5),"^",1,3)=X_"^"_PSGDT_"^"_DUZ
- G DONE
- ;
- QUES ;
- W !!," If a number is found in this field by the daily background job, the job will completely delete all PICK LISTS that have been FILED AWAY and have been around longer than the number of days specified in this field."
- W " Entering a number into",!,"this field will effectively start the AUTO PURGE. DELETING this field will",!,"effectively STOP the AUTO PURGE."
- W !?3,"ENTER THE NUMBER (1-90) OF DAYS THAT PICK LISTS THAT ARE FILED AWAY MAY STAY IN THE COMPUTER." Q
- ;
- KILL ;
- I 'ND W " NOTHING TO DELETE!" S X="" Q
- W !?5,"OK TO DELETE" S %=0 D YN^DICN I %=1 S ^PS(59.7,1,63.5)="^"_PSGDT_"^"_DUZ W " DELETED! (AUTO PURGE STOPPED.)" Q
- W $C(7)," <NOTHING DELETED>" S X="" Q
- PSGPLPRG ;BIR/CML3-PURGE PICK LISTS ;20 JUL 94 / 5:46 PM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**5**;16 DEC 97
- AP ;
- +1 DO ENCV^PSGSETU
- IF $DATA(XQUIT)
- QUIT
- +2 SET ND=$PIECE($GET(^PS(59.7,1,63.5)),"^",1,3)
- IF $PIECE(ND,"^",2)
- SET PSGOD=$$ENDTC^PSGMI($PIECE(ND,"^",2))
- +3 WRITE !!?$SELECT('$PIECE(ND,"^",2):24,ND:13,1:17),"** AUTO PURGE ",$SELECT(ND=""!(ND="^^"):"NEVER STARTED.",ND:"SET TO "_+ND_" DAYS",1:"STOPPED")
- IF $PIECE(ND,"^",2)
- WRITE ", AS OF ",PSGOD
- WRITE " **",!
- +4 ;
- DA ;
- +1 SET Y=-1
- SET %DT="EPTX"
- FOR
- READ !!,"Enter PURGE STOP DATE: ",X:DTIME
- IF '$TEST
- WRITE $CHAR(7)
- IF '$TEST
- SET X="^"
- IF X?1."?"
- DO DAM
- IF "^"'[X
- DO ^%DT
- IF Y>0!("^"[X)
- IF Y'>0
- WRITE !,$CHAR(7),"No date selected for purge run."
- QUIT
- +2 KILL %DT
- IF Y>0
- SET PSGPLPD=Y
- KILL ZTSAVE
- SET PSGTID=$HOROLOG
- SET PSGTIR="ENQ^PSGPLPRG"
- SET ZTSAVE("PSGPLPD")=""
- SET ZTDESC="PICK LIST PURGE"
- SET ZTIO=""
- DO ENNOIO^PSGTI
- IF $DATA(ZTSK)
- WRITE !,"Pick list purge queued!"
- +3 GOTO DONE
- +4 ;
- DAM ;
- +1 WRITE !!," If a date is entered here, all of the FILED AWAY PICK LISTS that started ",!,"before the entered date will be deleted."
- QUIT
- +2 ;
- ENQ ;
- +1 FOR Q=0:0
- SET Q=$ORDER(^PS(53.5,"AO",Q))
- IF 'Q
- QUIT
- Begin DoDot:1
- +2 FOR QQ=0:0
- SET QQ=$ORDER(^PS(53.5,"AO",Q,QQ))
- IF 'QQ!(QQ>PSGPLPD)
- QUIT
- Begin DoDot:2
- +3 FOR PLN=0:0
- SET PLN=$ORDER(^PS(53.5,"AO",Q,QQ,PLN))
- IF 'PLN
- QUIT
- Begin DoDot:3
- +4 KILL DA,DIK
- SET DIK="^PS(53.5,"
- SET DA=PLN
- DO ^DIK
- KILL ^PS(53.5,PLN)
- +5 IF $DATA(^PS(53.55,PLN))
- KILL DA,DIK
- SET DIK="^PS(53.55,"
- SET DA=PLN
- DO ^DIK
- KILL ^PS(53.55,PLN)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +6 ;
- DONE ;
- +1 DO ENKV^PSGSETU
- KILL AM,ND,PLN,PSGPLPD,ST
- QUIT
- +2 ;
- ENASK ; sets, resets, or deletes auto purge (# of days)
- +1 DO ENCV^PSGSETU
- IF $DATA(XQUIT)
- QUIT
- +2 DO NOW^%DTC
- SET PSGDT=%
- SET ND=$PIECE($GET(^PS(59.7,1,63.5)),"^",1,3)
- +3 FOR
- WRITE !!,"DAYS 'FILED AWAY' PICK LISTS SHOULD LAST",$SELECT(+ND:" "_+ND_"// ",1:": ")
- READ X:DTIME
- IF "^"[X!(X?1.2N&(X>0)&(X<91))
- QUIT
- IF X?1."?"
- DO QUES
- IF X="@"
- DO KILL
- IF X="@"
- QUIT
- IF X'?1."?"
- WRITE $CHAR(7)," ??"
- +4 IF X
- IF X'=+ND
- IF 'ND
- WRITE " (AUTO PURGE WILL ",$PIECE("^RE","^",ND]""+1),"START.)"
- SET $PIECE(^PS(59.7,1,63.5),"^",1,3)=X_"^"_PSGDT_"^"_DUZ
- +5 GOTO DONE
- +6 ;
- QUES ;
- +1 WRITE !!," If a number is found in this field by the daily background job, the job will completely delete all PICK LISTS that have been FILED AWAY and have been around longer than the number of days specified in this field."
- +2 WRITE " Entering a number into",!,"this field will effectively start the AUTO PURGE. DELETING this field will",!,"effectively STOP the AUTO PURGE."
- +3 WRITE !?3,"ENTER THE NUMBER (1-90) OF DAYS THAT PICK LISTS THAT ARE FILED AWAY MAY STAY IN THE COMPUTER."
- QUIT
- +4 ;
- KILL ;
- +1 IF 'ND
- WRITE " NOTHING TO DELETE!"
- SET X=""
- QUIT
- +2 WRITE !?5,"OK TO DELETE"
- SET %=0
- DO YN^DICN
- IF %=1
- SET ^PS(59.7,1,63.5)="^"_PSGDT_"^"_DUZ
- WRITE " DELETED! (AUTO PURGE STOPPED.)"
- QUIT
- +3 WRITE $CHAR(7)," <NOTHING DELETED>"
- SET X=""
- QUIT
