PSGPLUTL ;BIR/RLW-PICK LIST UTILITIES ;06 AUG 96 / 10:54 AM
;;5.0; INPATIENT MEDICATIONS ;**109**;16 DEC 97
;
PAT ; find next patient or jump to a new patient
I $E(OK,1,1)="^"&($P(OK,"^",2)?1.A) D JUMP Q
S PN=$O(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN))
Q
;
JUMP ; try to find patient user wants to jump to and construct "AC" xref
S DIC="^PS(53.5,"_PSGPLG_",1,",DIC(0)="EQZ",X=PSGP D ^DIC K DIC
Q
;
LOCK(PSGPLG,APPL) ; Pick List routines use an ^XTMP node instead of locking, to allow some jobs to run concurrently on the same Pick List (PRINT and SEND TO ATC).
; PSGPLG=pick list number, APPL=option attempting to "lock", SETAPPL=option already in progress, APPLOK=if '1', option attempting to "lock" can proceed.
N SETAPPL,APPLOK,SUB,PLG
D NOW^%DTC S X1=X,X2=1 D C^%DTC S ^XTMP("PSGPL",0)=X,APPLOK=0
; clean up XTMP nodes left by aborted jobs (for all pick lists)
S PLG=0 F S PLG=$O(^XTMP("PSGPL",PLG)) Q:PLG="" D
.S SETAPPL=0 F S SETAPPL=$O(^XTMP("PSGPL",PLG,SETAPPL)) Q:SETAPPL="" D
..S SUB=0 F S SUB=$O(^XTMP("PSGPL",PLG,SETAPPL,SUB)) Q:SUB="" L +^XTMP("PSGPL",PLG,SETAPPL,SUB):1 I K ^XTMP("PSGPL",PLG,SETAPPL,SUB) L -^XTMP("PSGPL",PLG,SETAPPL,SUB)
I '$D(^XTMP("PSGPL",PSGPLG)) S ^XTMP("PSGPL",PSGPLG,APPL,$J)="" L +^XTMP("PSGPL",PSGPLG,APPL,$J):1 Q 1
S SETAPPL=0 F S SETAPPL=$O(^XTMP("PSGPL",PSGPLG,SETAPPL)) Q:SETAPPL="" D
.I (APPL="PSGPLR")&((SETAPPL="PSGTAP")!(SETAPPL="PSGPLR")) S ^XTMP("PSGPL",PSGPLG,APPL,$J)="" L +^XTMP("PSGPL",PSGPLG,APPL,$J):1 S:$T APPLOK=1 Q
.I (APPL="PSGTAP")&(SETAPPL="PSGPLR") S ^XTMP("PSGPL",PSGPLG,APPL,$J)="" L +^XTMP("PSGPL",PSGPLG,APPL,$J):1 S:$T APPLOK=1 Q
Q APPLOK
;
UNLOCK(PSGPLG,APPL) ;.
L -^XTMP("PSGPL",PSGPLG,APPL,$J) K ^XTMP("PSGPL",PSGPLG,APPL,$J)
K:'$O(^XTMP("PSGPL",0)) ^XTMP("PSGPL")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPLUTL 1807 printed Dec 13, 2024@02:02:58 Page 2
PSGPLUTL ;BIR/RLW-PICK LIST UTILITIES ;06 AUG 96 / 10:54 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**109**;16 DEC 97
+2 ;
PAT ; find next patient or jump to a new patient
+1 IF $EXTRACT(OK,1,1)="^"&($PIECE(OK,"^",2)?1.A)
DO JUMP
QUIT
+2 SET PN=$ORDER(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN))
+3 QUIT
+4 ;
JUMP ; try to find patient user wants to jump to and construct "AC" xref
+1 SET DIC="^PS(53.5,"_PSGPLG_",1,"
SET DIC(0)="EQZ"
SET X=PSGP
DO ^DIC
KILL DIC
+2 QUIT
+3 ;
LOCK(PSGPLG,APPL) ; Pick List routines use an ^XTMP node instead of locking, to allow some jobs to run concurrently on the same Pick List (PRINT and SEND TO ATC).
+1 ; PSGPLG=pick list number, APPL=option attempting to "lock", SETAPPL=option already in progress, APPLOK=if '1', option attempting to "lock" can proceed.
+2 NEW SETAPPL,APPLOK,SUB,PLG
+3 DO NOW^%DTC
SET X1=X
SET X2=1
DO C^%DTC
SET ^XTMP("PSGPL",0)=X
SET APPLOK=0
+4 ; clean up XTMP nodes left by aborted jobs (for all pick lists)
+5 SET PLG=0
FOR
SET PLG=$ORDER(^XTMP("PSGPL",PLG))
if PLG=""
QUIT
Begin DoDot:1
+6 SET SETAPPL=0
FOR
SET SETAPPL=$ORDER(^XTMP("PSGPL",PLG,SETAPPL))
if SETAPPL=""
QUIT
Begin DoDot:2
+7 SET SUB=0
FOR
SET SUB=$ORDER(^XTMP("PSGPL",PLG,SETAPPL,SUB))
if SUB=""
QUIT
LOCK +^XTMP("PSGPL",PLG,SETAPPL,SUB):1
IF $TEST
KILL ^XTMP("PSGPL",PLG,SETAPPL,SUB)
LOCK -^XTMP("PSGPL",PLG,SETAPPL,SUB)
End DoDot:2
End DoDot:1
+8 IF '$DATA(^XTMP("PSGPL",PSGPLG))
SET ^XTMP("PSGPL",PSGPLG,APPL,$JOB)=""
LOCK +^XTMP("PSGPL",PSGPLG,APPL,$JOB):1
QUIT 1
+9 SET SETAPPL=0
FOR
SET SETAPPL=$ORDER(^XTMP("PSGPL",PSGPLG,SETAPPL))
if SETAPPL=""
QUIT
Begin DoDot:1
+10 IF (APPL="PSGPLR")&((SETAPPL="PSGTAP")!(SETAPPL="PSGPLR"))
SET ^XTMP("PSGPL",PSGPLG,APPL,$JOB)=""
LOCK +^XTMP("PSGPL",PSGPLG,APPL,$JOB):1
if $TEST
SET APPLOK=1
QUIT
+11 IF (APPL="PSGTAP")&(SETAPPL="PSGPLR")
SET ^XTMP("PSGPL",PSGPLG,APPL,$JOB)=""
LOCK +^XTMP("PSGPL",PSGPLG,APPL,$JOB):1
if $TEST
SET APPLOK=1
QUIT
End DoDot:1
+12 QUIT APPLOK
+13 ;
UNLOCK(PSGPLG,APPL) ;.
+1 LOCK -^XTMP("PSGPL",PSGPLG,APPL,$JOB)
KILL ^XTMP("PSGPL",PSGPLG,APPL,$JOB)
+2 if '$ORDER(^XTMP("PSGPL",0))
KILL ^XTMP("PSGPL")
+3 QUIT
