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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPLPRG 2478 printed Nov 22, 2024@17:12:58 Page 2
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
