PSGTAP0 ;BIR/CML3-SEND PICK LIST TO TRAVENOL'S ATC 212 ;18 APR 95 / 4:21 PM
;;5.0;INPATIENT MEDICATIONS;**119,284**;16 DEC 97;Build 7
;
S1 ;
W $C(48) F Q=1:1:75 R *X:$S(Q<15:1,1:5) G:X=49 S1 I X=48 Q
E S QUIT=1 Q
W A F Q=1:1:75 R *X:$S(Q<15:1,1:5) G:X=49 S1 I X=48 Q
S:'$T QUIT=1 Q
;
S2 ;
W $C(48) F Q=1:1:75 R X:$S(Q<15:1,1:5) G:$A(X)=49 S2 I $A(X)=48 Q
E S QUIT=1 Q
W A F Q=1:1:75 R X:$S(Q<15:1,1:5) G:$A(X)=49 S2 I $A(X)=48 Q
S:'$T QUIT=1 Q
Q
;
S3 ; *284 - Added ! to clear WR buffer for network channel
W $C(48),! F Q=1:1:75 R *X:$S(Q<15:1,1:5) G:X=49 S3 I X=48 Q
E S QUIT=1 Q
W A,! F Q=1:1:75 R *X:$S(Q<15:1,1:5) G:X=49 S3 I X=48 Q
S:'$T QUIT=1 Q
ENQ ;
N ATCFF,DNUNIT,PSGTAG
F Q:$$LOCK^PSGPLUTL(PSGPLG,"PSGTAP")
F L +^PS(53.55,PSGPLG):1 Q:$T
D NOW^%DTC S %=%_"0000000000000",DAT=$E(%,4,5)_$E(%,6,7)_$E(%,2,3)_$E(%,9,10)_$E(%,11,12) I PSGPLG<0 S QUIT=0 G QUIT
I PSGTAPR S ND=$P($G(^PS(53.55,PSGPLG,0)),"^",2) I ND,$O(^(1,0)) G RESTART
I $D(^PS(53.55,PSGPLG)) S DIK="^PS(53.55,",DA=PSGPLG D ^DIK
S (DINUM,X)=PSGPLG,DIC="^PS(53.55,",DIC(0)="L" K DD,DO D FILE^DICN I Y'>0 S QUIT=0 G QUIT
S ^PS(53.55,PSGPLG,1,0)="^53.56A",BLKS=" ",G=PSGPLG,(DD,PSGORD,PSJJORD,ND,P,R,S,T,W,O,D)=""
S ATCFF=+$P($G(^PS(59.7,1,26)),"^",7)
F S T=$O(^PS(53.5,"AC",G,T)) Q:T="" F S W=$O(^PS(53.5,"AC",G,T,W)) Q:W="" F S R=$O(^PS(53.5,"AC",G,T,W,R)) Q:R="" F S P=$O(^PS(53.5,"AC",G,T,W,R,P)) Q:P="" D ;
.S (DFN,PSGP)=+$P(P,"^",2) D PID^VADPT S PND=$S($D(^DPT(PSGP,0)):^(0),1:0),PL=$E($S($D(^(.1)):^(.1),1:"N/F")_BLKS,1,12),PN=$E($P(PND,"^")_BLKS,1,20),PID=$E(VA("PID")_BLKS,1,12),S="A"
.F S S=$O(^PS(53.5,"AC",G,T,W,R,P,S)) Q:"Z"[S F S PSGORD=$O(^PS(53.5,"AC",G,T,W,R,P,S,PSGORD)) Q:PSGORD="" S O=$P(PSGORD,"^",2) D
..S ON=+$G(^PS(53.5,G,1,PSGP,1,O,0)) F S DD=$O(^PS(53.5,"AC",G,T,W,R,P,S,PSGORD,DD)) Q:DD="" S D=+$P(DD,"^",2),C=$G(^PS(53.5,G,1,PSGP,1,O,1,D,0)),D=$P(C,"^"),C=$S($P(C,"^",3)]"":+$P(C,"^",3),1:$P(C,"^",2)) I C>0,C?1.3N D ;
...S DN=$G(^PS(55,PSGP,5,ON,1,D,0))
...S DNUNIT=$P(DN,"^",2) I DNUNIT#1,ATCFF,+DNUNIT S DNUNIT=(DNUNIT\1)+1
...I DN,'(DNUNIT#1),$S('$P(DN,"^",3):1,1:DT<$P(DN,"^",3)) S A=$P($G(^PSDRUG(+DN,8.5)),"^",2) I A]"",$D(^(212,"AC",PSGPLWG)) D
....S A=$E(A_BLKS,1,15) I C>99 F ND=ND+1:1 S ^PS(53.55,PSGPLG,1,ND,0)=PN_PID_PL_"BAT"_A_"1 ^099",C=C-99 Q:C<100
....Q:C<1 S:$L(C)<3 C=$E("000",1,3-$L(C))_C S ND=ND+1,^PS(53.55,PSGPLG,1,ND,0)=PN_PID_PL_"BAT"_A_"1 ^"_C Q
S QUIT=$O(^PS(53.55,PSGPLG,1,0)) G:'QUIT QUIT S ^(0)="^53.56A^"_ND_"^"_ND,ND=0
;
RESTART ;
X ^%ZOSF("LABOFF") S QUIT=0
F S ND=$O(^PS(53.55,PSGPLG,1,ND)) Q:'ND S A=$G(^(ND,0)) I A]"" S A=$C(50)_$C(52)_$P(A,"^")_$C(53)_$C(54)_$P(A,"^",2)_DAT_$C(55)_$C(13) S PSGTAG=$S(IOT="CHAN":"S3",'PSGSPD:"S1",1:"S2") D @PSGTAG Q:QUIT S $P(^PS(53.55,PSGPLG,0),"^",2)=ND
;
QUIT ;
I 'QUIT S DIK="^PS(53.55,",DA=PSGPLG D ^DIK
L -^PS(53.55,PSGPLG)
D UNLOCK^PSGPLUTL(PSGPLG,"PSGTAP") D ^%ZISC Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGTAP0 2982 printed Jun 11, 2024@21:52:46 Page 2
PSGTAP0 ;BIR/CML3-SEND PICK LIST TO TRAVENOL'S ATC 212 ;18 APR 95 / 4:21 PM
+1 ;;5.0;INPATIENT MEDICATIONS;**119,284**;16 DEC 97;Build 7
+2 ;
S1 ;
+1 WRITE $CHAR(48)
FOR Q=1:1:75
READ *X:$SELECT(Q<15:1,1:5)
if X=49
GOTO S1
IF X=48
QUIT
+2 IF '$TEST
SET QUIT=1
QUIT
+3 WRITE A
FOR Q=1:1:75
READ *X:$SELECT(Q<15:1,1:5)
if X=49
GOTO S1
IF X=48
QUIT
+4 if '$TEST
SET QUIT=1
QUIT
+5 ;
S2 ;
+1 WRITE $CHAR(48)
FOR Q=1:1:75
READ X:$SELECT(Q<15:1,1:5)
if $ASCII(X)=49
GOTO S2
IF $ASCII(X)=48
QUIT
+2 IF '$TEST
SET QUIT=1
QUIT
+3 WRITE A
FOR Q=1:1:75
READ X:$SELECT(Q<15:1,1:5)
if $ASCII(X)=49
GOTO S2
IF $ASCII(X)=48
QUIT
+4 if '$TEST
SET QUIT=1
QUIT
+5 QUIT
+6 ;
S3 ; *284 - Added ! to clear WR buffer for network channel
+1 WRITE $CHAR(48),!
FOR Q=1:1:75
READ *X:$SELECT(Q<15:1,1:5)
if X=49
GOTO S3
IF X=48
QUIT
+2 IF '$TEST
SET QUIT=1
QUIT
+3 WRITE A,!
FOR Q=1:1:75
READ *X:$SELECT(Q<15:1,1:5)
if X=49
GOTO S3
IF X=48
QUIT
+4 if '$TEST
SET QUIT=1
QUIT
ENQ ;
+1 NEW ATCFF,DNUNIT,PSGTAG
+2 FOR
if $$LOCK^PSGPLUTL(PSGPLG,"PSGTAP")
QUIT
+3 FOR
LOCK +^PS(53.55,PSGPLG):1
if $TEST
QUIT
+4 DO NOW^%DTC
SET %=%_"0000000000000"
SET DAT=$EXTRACT(%,4,5)_$EXTRACT(%,6,7)_$EXTRACT(%,2,3)_$EXTRACT(%,9,10)_$EXTRACT(%,11,12)
IF PSGPLG<0
SET QUIT=0
GOTO QUIT
+5 IF PSGTAPR
SET ND=$PIECE($GET(^PS(53.55,PSGPLG,0)),"^",2)
IF ND
IF $ORDER(^(1,0))
GOTO RESTART
+6 IF $DATA(^PS(53.55,PSGPLG))
SET DIK="^PS(53.55,"
SET DA=PSGPLG
DO ^DIK
+7 SET (DINUM,X)=PSGPLG
SET DIC="^PS(53.55,"
SET DIC(0)="L"
KILL DD,DO
DO FILE^DICN
IF Y'>0
SET QUIT=0
GOTO QUIT
+8 SET ^PS(53.55,PSGPLG,1,0)="^53.56A"
SET BLKS=" "
SET G=PSGPLG
SET (DD,PSGORD,PSJJORD,ND,P,R,S,T,W,O,D)=""
+9 SET ATCFF=+$PIECE($GET(^PS(59.7,1,26)),"^",7)
+10 ;
FOR
SET T=$ORDER(^PS(53.5,"AC",G,T))
if T=""
QUIT
FOR
SET W=$ORDER(^PS(53.5,"AC",G,T,W))
if W=""
QUIT
FOR
SET R=$ORDER(^PS(53.5,"AC",G,T,W,R))
if R=""
QUIT
FOR
SET P=$ORDER(^PS(53.5,"AC",G,T,W,R,P))
if P=""
QUIT
Begin DoDot:1
+11 SET (DFN,PSGP)=+$PIECE(P,"^",2)
DO PID^VADPT
SET PND=$SELECT($DATA(^DPT(PSGP,0)):^(0),1:0)
SET PL=$EXTRACT($SELECT($DATA(^(.1)):^(.1),1:"N/F")_BLKS,1,12)
SET PN=$EXTRACT($PIECE(PND,"^")_BLKS,1,20)
SET PID=$EXTRACT(VA("PID")_BLKS,1,12)
SET S="A"
+12 FOR
SET S=$ORDER(^PS(53.5,"AC",G,T,W,R,P,S))
if "Z"[S
QUIT
FOR
SET PSGORD=$ORDER(^PS(53.5,"AC",G,T,W,R,P,S,PSGORD))
if PSGORD=""
QUIT
SET O=$PIECE(PSGORD,"^",2)
Begin DoDot:2
+13 ;
SET ON=+$GET(^PS(53.5,G,1,PSGP,1,O,0))
FOR
SET DD=$ORDER(^PS(53.5,"AC",G,T,W,R,P,S,PSGORD,DD))
if DD=""
QUIT
SET D=+$PIECE(DD,"^",2)
SET C=$GET(^PS(53.5,G,1,PSGP,1,O,1,D,0))
SET D=$PIECE(C,"^")
SET C=$SELECT($PIECE(C,"^",3)]"":+$PIECE(C,"^",3),1:$PIECE(C,"^",2))
IF C>0
IF C?1.3N
Begin DoDot:3
+14 SET DN=$GET(^PS(55,PSGP,5,ON,1,D,0))
+15 SET DNUNIT=$PIECE(DN,"^",2)
IF DNUNIT#1
IF ATCFF
IF +DNUNIT
SET DNUNIT=(DNUNIT\1)+1
+16 IF DN
IF '(DNUNIT#1)
IF $SELECT('$PIECE(DN,"^",3):1,1:DT<$PIECE(DN,"^",3))
SET A=$PIECE($GET(^PSDRUG(+DN,8.5)),"^",2)
IF A]""
IF $DATA(^(212,"AC",PSGPLWG))
Begin DoDot:4
+17 SET A=$EXTRACT(A_BLKS,1,15)
IF C>99
FOR ND=ND+1:1
SET ^PS(53.55,PSGPLG,1,ND,0)=PN_PID_PL_"BAT"_A_"1 ^099"
SET C=C-99
if C<100
QUIT
+18 if C<1
QUIT
if $LENGTH(C)<3
SET C=$EXTRACT("000",1,3-$LENGTH(C))_C
SET ND=ND+1
SET ^PS(53.55,PSGPLG,1,ND,0)=PN_PID_PL_"BAT"_A_"1 ^"_C
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 SET QUIT=$ORDER(^PS(53.55,PSGPLG,1,0))
if 'QUIT
GOTO QUIT
SET ^(0)="^53.56A^"_ND_"^"_ND
SET ND=0
+20 ;
RESTART ;
+1 XECUTE ^%ZOSF("LABOFF")
SET QUIT=0
+2 FOR
SET ND=$ORDER(^PS(53.55,PSGPLG,1,ND))
if 'ND
QUIT
SET A=$GET(^(ND,0))
IF A]""
SET A=$CHAR(50)_$CHAR(52)_$PIECE(A,"^")_$CHAR(53)_$CHAR(54)_$PIECE(A,"^",2)_DAT_$CHAR(55)_$CHAR(13)
SET PSGTAG=$SELECT(IOT="CHAN":"S3",'PSGSPD:"S1",1:"S2")
DO @PSGTAG
if QUIT
QUIT
SET $PIECE(^PS(53.55,PSGPLG,0),"^",2)=ND
+3 ;
QUIT ;
+1 IF 'QUIT
SET DIK="^PS(53.55,"
SET DA=PSGPLG
DO ^DIK
+2 LOCK -^PS(53.55,PSGPLG)
+3 DO UNLOCK^PSGPLUTL(PSGPLG,"PSGTAP")
DO ^%ZISC
QUIT
