PSGPLUTL.m

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

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