Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSGPLUTL

PSGPLUTL.m

Go to the documentation of this file.
  1. PSGPLUTL ;BIR/RLW-PICK LIST UTILITIES ;06 AUG 96 / 10:54 AM
  1. ;;5.0; INPATIENT MEDICATIONS ;**109**;16 DEC 97
  1. ;
  1. PAT ; find next patient or jump to a new patient
  1. I $E(OK,1,1)="^"&($P(OK,"^",2)?1.A) D JUMP Q
  1. S PN=$O(^PS(53.5,"AC",PSGPLG,TM,WDN,RB,PN))
  1. Q
  1. ;
  1. JUMP ; try to find patient user wants to jump to and construct "AC" xref
  1. S DIC="^PS(53.5,"_PSGPLG_",1,",DIC(0)="EQZ",X=PSGP D ^DIC K DIC
  1. Q
  1. ;
  1. 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.
  1. N SETAPPL,APPLOK,SUB,PLG
  1. D NOW^%DTC S X1=X,X2=1 D C^%DTC S ^XTMP("PSGPL",0)=X,APPLOK=0
  1. ; clean up XTMP nodes left by aborted jobs (for all pick lists)
  1. S PLG=0 F S PLG=$O(^XTMP("PSGPL",PLG)) Q:PLG="" D
  1. .S SETAPPL=0 F S SETAPPL=$O(^XTMP("PSGPL",PLG,SETAPPL)) Q:SETAPPL="" D
  1. ..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)
  1. I '$D(^XTMP("PSGPL",PSGPLG)) S ^XTMP("PSGPL",PSGPLG,APPL,$J)="" L +^XTMP("PSGPL",PSGPLG,APPL,$J):1 Q 1
  1. S SETAPPL=0 F S SETAPPL=$O(^XTMP("PSGPL",PSGPLG,SETAPPL)) Q:SETAPPL="" D
  1. .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
  1. .I (APPL="PSGTAP")&(SETAPPL="PSGPLR") S ^XTMP("PSGPL",PSGPLG,APPL,$J)="" L +^XTMP("PSGPL",PSGPLG,APPL,$J):1 S:$T APPLOK=1 Q
  1. Q APPLOK
  1. ;
  1. UNLOCK(PSGPLG,APPL) ;.
  1. L -^XTMP("PSGPL",PSGPLG,APPL,$J) K ^XTMP("PSGPL",PSGPLG,APPL,$J)
  1. K:'$O(^XTMP("PSGPL",0)) ^XTMP("PSGPL")
  1. Q