PSGTAP ;BIR/CML3-SEND PICK LIST TO TRAVENOL'S ATC 212 (DRIVER) ; 05 May 98 / 10:25 AM
;;5.0; INPATIENT MEDICATIONS ;**10**;16 DEC 97
;
EN ;
D ENCV^PSGSETU I $D(XQUIT) Q
;
ASK ;
R !!,"Select WARD GROUP or PICK LIST: ",X:DTIME W:'$T $C(7) S:'$T X="^" G:"^"[X OUT I X=+X D NL G:'$D(X) ASK I Y D EN1 G ASK
I X?1."?" W !!?2,"Select a Ward Group for which a pick list has been run that you wish to send",!,"to the ATC.",!?2,"You may also directly select a Pick List by number, which prints in the upper",!,"left corner of each pick list." G ASK
K DIC S DIC="^PS(57.5,",DIC(0)="EIMQZ",DIC("S")="I $P(^(0),""^"",2)=""P""" D ^DIC K DIC I Y S PSGPLWG=+Y,PSGPLGF="A" D AD I $D(X) F D ^PSGPLG Q:'PSGPLG D EN1 Q:OK
G ASK
;
OUT ;
D ENKV^PSGSETU K A,BLKS,C,D,DAT,DIC,G,I1,I2,ND,O,P,PID,PL,PN,PND,PSGIOP,PSGPLG,PSGPLGF,PSGPLWG,PSGPLWGN,PSGSPD,Q,QUIT,R,S,ST,T,TM,W
Q
;
EN1 ;
S OK=0 I '$$LOCK^PSGPLUTL(PSGPLG,"PSGTAP") W $C(7),!!,"This PICK LIST is currently being accessed by another task." Q
I $P($G(^PS(53.5,PSGPLG,0)),"^",12) S PSGID=$P(^(0),"^",12),PSGOD=$$ENDTC^PSGMI(PSGID) D I Y<1 D EN2 Q
.W !! S DIR(0)="Y^A",DIR("A")="Pick List #"_PSGPLG_" was queued to the ATC for "_PSGOD_". Send again",DIR("B")="N" D ^DIR K DIR
S X=$G(^PS(53.5,PSGPLG,0)),Y=$O(^(0))="",X=$P(X,"^",11)&'$P(X,"^",9),%=1
I X!Y W $C(7) F W !!,"THIS PICK LIST HAS NO",$S(Y:" DATA.",1:"T RUN TO COMPLETION."),!,"Do you wish to continue" S %=2 D YN^DICN G:% EN2 W !!?2,"Enter 'YES' to send this pick list to the ATC. Enter 'NO' (or '^') to not",!,"send it."
G:%'=1 EN2 K %ZIS S %ZIS="NQ",PSGION=ION,IOP="`"_PSGIOP_";255" D ^%ZIS I POP S IOP=PSGION D ^%ZIS K IOP W $C(7),!!?10,"THE ATC MACHINE IS NOT FOUND!" G EN2
S PSGTAPR=0 I $D(^PS(53.55,PSGPLG,0)),$P(^(0),"^",2),$O(^(1,0)) F W !!,"This pick list had been previously started, but did not run to completion.",!,"Do you want to restart it where it left off" S %=0 D YN^DICN I 1 Q:% D
.W !!?2,"Enter 'YES' to restart the pick list from where it previously stopped. Enter",!,"'NO' to start this pick list from the beginning." W:%Y'?1."?" " (A response is required.)"
I G:%<0 EN2 S PSGTAPR=%=1
S X=0,X=$O(^PS(59.7,X)),PSGTIR=$S($P($G(^(X,26)),"^",2)=1:"ENQ^PSGTAP1",1:"ENQ^PSGTAP0")
K PSGTID,ZTSAVE S ZTDESC="PICK LIST TO ATC",(ZTSAVE("PSGPLG"),ZTSAVE("PSGSPD"),ZTSAVE("PSGTAPR"),ZTSAVE("PSGPLWG"))="" D ENTSK^PSGTI
I $D(ZTSK) W "...SENT!" S OK=1 I $D(ZTSK("D"))#2 S %H=ZTSK("D") D YMD^%DTC S $P(^PS(53.5,PSGPLG,0),"^",12)=X+%
;
EN2 ;
I $D(PSGPLG) D UNLOCK^PSGPLUTL(PSGPLG,"PSGTAP")
Q
;
NL ; numeric look-up
S Y=$G(^PS(53.5,X,0)) I $S('Y:1,'$P(Y,"^",2):1,1:'$D(^PS(53.5,"AB",$P(Y,"^",2),+$P(Y,"^",3),X))) S Y=0 Q
S PSGPLG=X,X=^PS(53.5,PSGPLG,0),Y=$$ENDTC^PSGMI($P(X,"^",3)),PSGPLWG=$P(X,"^",2),PSGPLWGN=$S('$D(^PS(57.5,PSGPLWG,0)):PSGPLWG_";PS(57.5,",$P(^(0),"^")]"":$P(^(0),"^"),1:PSGPLWG_";PS(57.5,"),PSGOD=$$ENDTC^PSGMI($P(X,"^",4))
W !?5,"Ward Group: ",PSGPLWGN,!?5,Y," thru ",PSGOD
;
AD ; ATC device
S X=$G(^PS(57.5,PSGPLWG,3)) I $P(X,"^",3)="" W $C(7),!!?3,"THIS WARD GROUP DOES NOT HAVE AN ATC DEVICE DESIGNATED FOR IT." K X
S:$D(X) PSGIOP=$P(X,"^",3),PSGSPD=$P(X,"^",2),Y=1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGTAP 3177 printed Dec 13, 2024@02:03:18 Page 2
PSGTAP ;BIR/CML3-SEND PICK LIST TO TRAVENOL'S ATC 212 (DRIVER) ; 05 May 98 / 10:25 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**10**;16 DEC 97
+2 ;
EN ;
+1 DO ENCV^PSGSETU
IF $DATA(XQUIT)
QUIT
+2 ;
ASK ;
+1 READ !!,"Select WARD GROUP or PICK LIST: ",X:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST
SET X="^"
if "^"[X
GOTO OUT
IF X=+X
DO NL
if '$DATA(X)
GOTO ASK
IF Y
DO EN1
GOTO ASK
+2 IF X?1."?"
WRITE !!?2,"Select a Ward Group for which a pick list has been run that you wish to send",!,"to the ATC.",!?2,"You may also directly select a Pick List by number, which prints in the upper",!,"left corner of each pick list."
GOTO ASK
+3 KILL DIC
SET DIC="^PS(57.5,"
SET DIC(0)="EIMQZ"
SET DIC("S")="I $P(^(0),""^"",2)=""P"""
DO ^DIC
KILL DIC
IF Y
SET PSGPLWG=+Y
SET PSGPLGF="A"
DO AD
IF $DATA(X)
FOR
DO ^PSGPLG
if 'PSGPLG
QUIT
DO EN1
if OK
QUIT
+4 GOTO ASK
+5 ;
OUT ;
+1 DO ENKV^PSGSETU
KILL A,BLKS,C,D,DAT,DIC,G,I1,I2,ND,O,P,PID,PL,PN,PND,PSGIOP,PSGPLG,PSGPLGF,PSGPLWG,PSGPLWGN,PSGSPD,Q,QUIT,R,S,ST,T,TM,W
+2 QUIT
+3 ;
EN1 ;
+1 SET OK=0
IF '$$LOCK^PSGPLUTL(PSGPLG,"PSGTAP")
WRITE $CHAR(7),!!,"This PICK LIST is currently being accessed by another task."
QUIT
+2 IF $PIECE($GET(^PS(53.5,PSGPLG,0)),"^",12)
SET PSGID=$PIECE(^(0),"^",12)
SET PSGOD=$$ENDTC^PSGMI(PSGID)
Begin DoDot:1
+3 WRITE !!
SET DIR(0)="Y^A"
SET DIR("A")="Pick List #"_PSGPLG_" was queued to the ATC for "_PSGOD_". Send again"
SET DIR("B")="N"
DO ^DIR
KILL DIR
End DoDot:1
IF Y<1
DO EN2
QUIT
+4 SET X=$GET(^PS(53.5,PSGPLG,0))
SET Y=$ORDER(^(0))=""
SET X=$PIECE(X,"^",11)&'$PIECE(X,"^",9)
SET %=1
+5 IF X!Y
WRITE $CHAR(7)
FOR
WRITE !!,"THIS PICK LIST HAS NO",$SELECT(Y:" DATA.",1:"T RUN TO COMPLETION."),!,"Do you wish to continue"
SET %=2
DO YN^DICN
if %
GOTO EN2
WRITE !!?2,"Enter 'YES' to send this pick list to the ATC. Enter 'NO' (or '^') to not",!,"send it."
+6 if %'=1
GOTO EN2
KILL %ZIS
SET %ZIS="NQ"
SET PSGION=ION
SET IOP="`"_PSGIOP_";255"
DO ^%ZIS
IF POP
SET IOP=PSGION
DO ^%ZIS
KILL IOP
WRITE $CHAR(7),!!?10,"THE ATC MACHINE IS NOT FOUND!"
GOTO EN2
+7 SET PSGTAPR=0
IF $DATA(^PS(53.55,PSGPLG,0))
IF $PIECE(^(0),"^",2)
IF $ORDER(^(1,0))
FOR
WRITE !!,"This pick list had been previously started, but did not run to completion.",!,"Do you want to restart it where it left off"
SET %=0
DO YN^DICN
IF 1
if %
QUIT
Begin DoDot:1
+8 WRITE !!?2,"Enter 'YES' to restart the pick list from where it previously stopped. Enter",!,"'NO' to start this pick list from the beginning."
if %Y'?1."?"
WRITE " (A response is required.)"
End DoDot:1
+9 IF $TEST
if %<0
GOTO EN2
SET PSGTAPR=%=1
+10 SET X=0
SET X=$ORDER(^PS(59.7,X))
SET PSGTIR=$SELECT($PIECE($GET(^(X,26)),"^",2)=1:"ENQ^PSGTAP1",1:"ENQ^PSGTAP0")
+11 KILL PSGTID,ZTSAVE
SET ZTDESC="PICK LIST TO ATC"
SET (ZTSAVE("PSGPLG"),ZTSAVE("PSGSPD"),ZTSAVE("PSGTAPR"),ZTSAVE("PSGPLWG"))=""
DO ENTSK^PSGTI
+12 IF $DATA(ZTSK)
WRITE "...SENT!"
SET OK=1
IF $DATA(ZTSK("D"))#2
SET %H=ZTSK("D")
DO YMD^%DTC
SET $PIECE(^PS(53.5,PSGPLG,0),"^",12)=X+%
+13 ;
EN2 ;
+1 IF $DATA(PSGPLG)
DO UNLOCK^PSGPLUTL(PSGPLG,"PSGTAP")
+2 QUIT
+3 ;
NL ; numeric look-up
+1 SET Y=$GET(^PS(53.5,X,0))
IF $SELECT('Y:1,'$PIECE(Y,"^",2):1,1:'$DATA(^PS(53.5,"AB",$PIECE(Y,"^",2),+$PIECE(Y,"^",3),X)))
SET Y=0
QUIT
+2 SET PSGPLG=X
SET X=^PS(53.5,PSGPLG,0)
SET Y=$$ENDTC^PSGMI($PIECE(X,"^",3))
SET PSGPLWG=$PIECE(X,"^",2)
SET PSGPLWGN=$SELECT('$DATA(^PS(57.5,PSGPLWG,0)):PSGPLWG_";PS(57.5,",$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:PSGPLWG_";PS(57.5,")
SET PSGOD=$$ENDTC^PSGMI($PIECE(X,"^",4))
+3 WRITE !?5,"Ward Group: ",PSGPLWGN,!?5,Y," thru ",PSGOD
+4 ;
AD ; ATC device
+1 SET X=$GET(^PS(57.5,PSGPLWG,3))
IF $PIECE(X,"^",3)=""
WRITE $CHAR(7),!!?3,"THIS WARD GROUP DOES NOT HAVE AN ATC DEVICE DESIGNATED FOR IT."
KILL X
+2 if $DATA(X)
SET PSGIOP=$PIECE(X,"^",3)
SET PSGSPD=$PIECE(X,"^",2)
SET Y=1
QUIT
