- PSGTAP1 ;BIR/CML3-SEND PICK LIST TO ATC BY PATIENT/ADMIN TIME ;19 Nov 98 / 2:37 PM
- ;;5.0;INPATIENT MEDICATIONS;**10,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 ND,G,TM,W,R,P,ST,DD,ATCFF,DNUNIT,PSGTAG K ^TMP("PSGATC",$J)
- F Q:$$LOCK^PSGPLUTL(PSGPLG,"PSGTAP")
- F L +^PS(53.55,PSGPLG):1 Q:$T
- D NOW^%DTC S %=%_"0000000000000",PSGPLSD=$P(^PS(53.5,PSGPLG,0),"^",3),PSGPLED=$P(^(0),"^",4) I 'PSGPLSD!'PSGPLED 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 ATCFF=+$P($G(^PS(59.7,1,26)),"^",7)
- S ^PS(53.55,PSGPLG,1,0)="^53.56A",BLKS=" ",G=PSGPLG,(DD,PSGORD,PSJJORD,ND,P,R,ST,TM,W)=""
- F S TM=$O(^PS(53.5,"AC",G,TM)) Q:TM="" F S W=$O(^PS(53.5,"AC",G,TM,W)) Q:W="" F S R=$O(^PS(53.5,"AC",G,TM,W,R)) Q:R="" F S P=$O(^PS(53.5,"AC",G,TM,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 ST="" F S ST=$O(^PS(53.5,"AC",G,TM,W,R,P,ST)) Q:ST="" Q:"Z"[ST F S PSGORD=$O(^PS(53.5,"AC",G,TM,W,R,P,ST,PSGORD)) Q:PSGORD="" S ON=+$G(^PS(53.5,G,1,PSGP,1,$P(PSGORD,"^",2),0)),DD="" D
- ..F S DD=$O(^PS(53.5,"AC",G,TM,W,R,P,ST,PSGORD,DD)) Q:DD="" S D=+$P(DD,"^",2),C=$G(^PS(53.5,G,1,PSGP,1,$P(PSGORD,"^",2),1,D,0)),O=$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)) S A=$E(A_BLKS,1,15),C=$S(DNUNIT:DNUNIT,1:1),C=$E("000",1,3-$L(C))_C D OS
- ;
- SET ; write ^TMP global to ACT file
- S ND=0,(X,Y)="^TMP(""PSGATC"","_$J,X=X_")"
- F S X=$Q(@X) Q:X'[Y S ND=ND+1,^PS(53.55,PSGPLG,1,ND,0)=$G(@X)
- 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)_$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 ;
- K ^TMP("PSGATC",$J)
- I 'QUIT S DIK="^PS(53.55,",DA=PSGPLG D ^DIK K DIK
- L -^PS(53.55,PSGPLG)
- D UNLOCK^PSGPLUTL(PSGPLG,"PSGTAP") D ^%ZISC
- Q
- ;
- OS ; order record set
- S ND2=$G(^PS(55,PSGP,5,ON,2)),SD=$P(ND2,U,2) I $S($P(SD,".")>$P(^PS(53.5,PSGPLG,0),"^",4):1,$P(ND2,U)["PRN":1,1:0) Q
- S FD=$P($P(ND2,U,4),"."),T=$P(ND2,U,6),PST=$P(^PS(55,PSGP,5,ON,0),"^",7)
- S QST=$S(PST="C"!(PST="O"):PST,PST="OC":"OA",PST="P":"OP",$P(ND2,U)["PRN":"OR",1:"CR")
- ;S:PST="OC" PSGMAR("ZZZ")="999"
- D:PST'="OC" DTS
- Q:'$D(PSGMAR)
- I $P(ND2,U,6)="D",$P(ND2,U,5)="" S $P(ND2,U,5)=$E($P($P(ND2,U,2),".",2)_"0000",1,4)
- S X="" F S X=$O(PSGMAR(X)) Q:X="" D
- .S ^TMP("PSGATC",$J,TM,W,R,PN_"^"_PSGP,X,QST,PSGORD,DD)=PN_PID_PL_"BAT"_A_"1 ^"_C_$E($E(X,4,5)_$E(X,6,7)_$E(X,2,3)_$P(X,".",2)_"000",1,10)
- K PSGMAR Q
- ;
- DTS ;
- S PSGPLO=ON,PSGMFOR="",PSGPLS=PSGPLSD,PSGPLF=PSGPLED D ^PSJPL0
- K PSGPLO,PSGPLS,PSGPLF
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGTAP1 3868 printed Feb 18, 2025@23:29:43 Page 2
- PSGTAP1 ;BIR/CML3-SEND PICK LIST TO ATC BY PATIENT/ADMIN TIME ;19 Nov 98 / 2:37 PM
- +1 ;;5.0;INPATIENT MEDICATIONS;**10,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
- +5 ;
- ENQ ;
- +1 NEW ND,G,TM,W,R,P,ST,DD,ATCFF,DNUNIT,PSGTAG
- KILL ^TMP("PSGATC",$JOB)
- +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 PSGPLSD=$PIECE(^PS(53.5,PSGPLG,0),"^",3)
- SET PSGPLED=$PIECE(^(0),"^",4)
- IF 'PSGPLSD!'PSGPLED
- 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 ATCFF=+$PIECE($GET(^PS(59.7,1,26)),"^",7)
- +9 SET ^PS(53.55,PSGPLG,1,0)="^53.56A"
- SET BLKS=" "
- SET G=PSGPLG
- SET (DD,PSGORD,PSJJORD,ND,P,R,ST,TM,W)=""
- +10 FOR
- SET TM=$ORDER(^PS(53.5,"AC",G,TM))
- if TM=""
- QUIT
- FOR
- SET W=$ORDER(^PS(53.5,"AC",G,TM,W))
- if W=""
- QUIT
- FOR
- SET R=$ORDER(^PS(53.5,"AC",G,TM,W,R))
- if R=""
- QUIT
- FOR
- SET P=$ORDER(^PS(53.5,"AC",G,TM,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)
- +12 SET ST=""
- FOR
- SET ST=$ORDER(^PS(53.5,"AC",G,TM,W,R,P,ST))
- if ST=""
- QUIT
- if "Z"[ST
- QUIT
- FOR
- SET PSGORD=$ORDER(^PS(53.5,"AC",G,TM,W,R,P,ST,PSGORD))
- if PSGORD=""
- QUIT
- SET ON=+$GET(^PS(53.5,G,1,PSGP,1,$PIECE(PSGORD,"^",2),0))
- SET DD=""
- Begin DoDot:2
- +13 FOR
- SET DD=$ORDER(^PS(53.5,"AC",G,TM,W,R,P,ST,PSGORD,DD))
- if DD=""
- QUIT
- SET D=+$PIECE(DD,"^",2)
- SET C=$GET(^PS(53.5,G,1,PSGP,1,$PIECE(PSGORD,"^",2),1,D,0))
- SET O=$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))
- SET A=$EXTRACT(A_BLKS,1,15)
- SET C=$SELECT(DNUNIT:DNUNIT,1:1)
- SET C=$EXTRACT("000",1,3-$LENGTH(C))_C
- DO OS
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +17 ;
- SET ; write ^TMP global to ACT file
- +1 SET ND=0
- SET (X,Y)="^TMP(""PSGATC"","_$JOB
- SET X=X_")"
- +2 FOR
- SET X=$QUERY(@X)
- if X'[Y
- QUIT
- SET ND=ND+1
- SET ^PS(53.55,PSGPLG,1,ND,0)=$GET(@X)
- +3 SET QUIT=$ORDER(^PS(53.55,PSGPLG,1,0))
- if 'QUIT
- GOTO QUIT
- SET ^(0)="^53.56A^"_ND_"^"_ND
- SET ND=0
- +4 ;
- 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)_$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 KILL ^TMP("PSGATC",$JOB)
- +2 IF 'QUIT
- SET DIK="^PS(53.55,"
- SET DA=PSGPLG
- DO ^DIK
- KILL DIK
- +3 LOCK -^PS(53.55,PSGPLG)
- +4 DO UNLOCK^PSGPLUTL(PSGPLG,"PSGTAP")
- DO ^%ZISC
- +5 QUIT
- +6 ;
- OS ; order record set
- +1 SET ND2=$GET(^PS(55,PSGP,5,ON,2))
- SET SD=$PIECE(ND2,U,2)
- IF $SELECT($PIECE(SD,".")>$PIECE(^PS(53.5,PSGPLG,0),"^",4):1,$PIECE(ND2,U)["PRN":1,1:0)
- QUIT
- +2 SET FD=$PIECE($PIECE(ND2,U,4),".")
- SET T=$PIECE(ND2,U,6)
- SET PST=$PIECE(^PS(55,PSGP,5,ON,0),"^",7)
- +3 SET QST=$SELECT(PST="C"!(PST="O"):PST,PST="OC":"OA",PST="P":"OP",$PIECE(ND2,U)["PRN":"OR",1:"CR")
- +4 ;S:PST="OC" PSGMAR("ZZZ")="999"
- +5 if PST'="OC"
- DO DTS
- +6 if '$DATA(PSGMAR)
- QUIT
- +7 IF $PIECE(ND2,U,6)="D"
- IF $PIECE(ND2,U,5)=""
- SET $PIECE(ND2,U,5)=$EXTRACT($PIECE($PIECE(ND2,U,2),".",2)_"0000",1,4)
- +8 SET X=""
- FOR
- SET X=$ORDER(PSGMAR(X))
- if X=""
- QUIT
- Begin DoDot:1
- +9 SET ^TMP("PSGATC",$JOB,TM,W,R,PN_"^"_PSGP,X,QST,PSGORD,DD)=PN_PID_PL_"BAT"_A_"1 ^"_C_$EXTRACT($EXTRACT(X,4,5)_$EXTRACT(X,6,7)_$EXTRACT(X,2,3)_$PIECE(X,".",2)_"000",1,10)
- End DoDot:1
- +10 KILL PSGMAR
- QUIT
- +11 ;
- DTS ;
- +1 SET PSGPLO=ON
- SET PSGMFOR=""
- SET PSGPLS=PSGPLSD
- SET PSGPLF=PSGPLED
- DO ^PSJPL0
- +2 KILL PSGPLO,PSGPLS,PSGPLF
- +3 QUIT