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