- 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 Feb 18, 2025@23:29:21 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