PSGEUD.m

PSGEUD ;BIR/CML3-EXTRA UNITS DISPENSED ;17 SEP 97 /  1:41 PM

 ;;5.0; INPATIENT MEDICATIONS ;**31,41,50,111,150,164**;16 DEC 97

 ;

 ; Reference to ^PSDRUG( is supported by DBIA 2192.

 ; Reference to ^PS(50.7 is supported by DBIA 2180.

 ; Reference to ^PS(51.2 is supported by DBIA 2178.

 ; Reference to ^PS(55 is supported by DBIA 2191.

 ;

 N PSJNEW,PSGPTMP,PPAGE,PSGEFN S PSJNEW=1

 D ENCV^PSGSETU Q:$D(XQUIT)  S (PSGONNV,PSGRETF)=1 K PSGPRP

 ;

GP ;

 S PSGP="",DFN=""

 D ENDPT^PSGP G:(PSGP'>0)&(DFN'>0)!('$D(PSJPAD)) DONE S:PSGP<1 PSGP=DFN I '$O(^PS(55,PSGP,5,"AUS",+PSJPAD)) W $C(7),!,"(Patient has NO active or old orders.)" G GP

 D ENL^PSGOU G:"^N"[PSGOL GP S PSGPTMP=0,PPAGE=1 D ^PSGO G:'PSGON GP S PSGLMT=PSGON,(PSGONC,PSGONR)=0

 F  W !!,"Select ORDER",$E("S",PSGON>1)," 1-",PSGON,": " R X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X  D:X?1."?" H I X'?1."?" D ENCHK^PSGON W:'$D(X) $C(7),"  ??" Q:$D(X)

 G:"^"[X GP F PSGRET=1:1:PSGODDD F PSGRET1=1:1 S PSGRET2=$P(PSGODDD(PSGRET),",",PSGRET1) Q:'PSGRET2  S PSGORD=^TMP("PSJON",$J,PSGRET2) D R G:$D(DTOUT) GP

 G GP

 ;

DONE ;

 D ENKV^PSGSETU K ^TMP("PSJON",$J),DO,DRGN,MR,OD,PSGLMT,PSGODDD,PSGEUD,PSGEUDA,PSGOL,PSGON,PSGONC,PSGONR,PSGONV,PSGONNV,PSGORD,PSGQ,PSGRET,PSGRET1,PSGRET2,PSGRETF,PSGSPD,SCH,WG,Z,CST Q

 ;

R ;

 S MR=$P($G(^PS(55,PSGP,5,+PSGORD,0)),"^",3),Y=$G(^(.2)),SCH=$P($G(^(2)),"^"),DO=$P(Y,"^",2),DRG=$P(Y,"^"),DRG=$S(DRG'=+DRG:"NOT FOUND",'$D(^PS(50.7,DRG,0)):DRG,$P(^(0),"^")]"":$P(^(0),"^"),1:DRG_";PS(50.7,")

 S:MR]"" MR=$S(MR'=MR:MR,'$D(^PS(51.2,MR,0)):MR,$P(^(0),"^",3)]"":$P(^(0),"^",3),$P(^(0),"^")]"":$P(^(0),"^"),1:MR_";PS(51.2,") W !!,"----------------------------------------",!,DRG,!,"Give: " D

 .N LN,MARX D TXT^PSGMUTL(DO_" "_MR_" "_SCH,65)

 .S LN="" F  S LN=$O(MARX(LN)) Q:LN=""  W:LN>1 ! W ?6,MARX(LN)

 I '$O(^PS(55,PSGP,5,+PSGORD,1,0)) D  Q

 .W !!,"No Dispense drugs have been entered for this order. At least one Dispense drugs",!,"must be associated with an order before dispensing information may be entered.",!!

 .N DIR S DIR(0)="E" D ^DIR S Y=$S(Y:0,1:1)

 S PSGEUD=0,WG=$O(^PS(57.5,"AB",+PSJPWD,0)) F DRG=0:0 S DRG=$O(^PS(55,PSGP,5,+PSGORD,1,DRG)) Q:'DRG  S X=$G(^(DRG,0)) I X D  Q:$D(DTOUT)

 .S UD=$P(X,"^",2),DRGN=$$ENDDN^PSGMI(+X) Q:DRGN=""  S:'$D(^PSDRUG(+X,212,"AC",+WG)) WG=""

 .I ($P(X,"^",3)?7N)&($P(PSGDT,".")'<$P(X,"^",3)) W !!,"Dispense drug: ",DRGN," **ORDER INACTIVE**" Q

 .I ($G(^PSDRUG(+X,"I"))?7N)&($P(PSGDT,".")'<$G(^PSDRUG(+X,"I"))) W !!,"Dispense drug: ",DRGN," **DRUG INACTIVE**" Q

 .W !!,"Dispense drug: ",DRGN,"  (U/D: ",$S('UD:1,1:UD),")"

 .K DA,DR S DA=+DRG,DA(2)=PSGP,DA(1)=+PSGORD,DIE="^PS(55,"_PSGP_",5,"_+PSGORD_",1,",DR=.11 S:$P($G(^PS(55,PSGP,5,+PSGORD,1,DA,0)),"^",11) $P(^(0),"^",11)=""

 .D ^DIE S PSGEUD=PSGEUD+$P($G(^PS(55,PSGP,5,+PSGORD,1,DA,0)),U,11)

 I PSGEUD,WG D QS

 Q

 ;

QS ;

 W !!,"THIS DRUG IS AN ATC ITEM." S Y=$G(^PS(57.5,WG,3)) I $P(Y,"^",3)="" W $C(7),"  BUT THE ATC DEVICE CANNOT BE FOUND!" S Y=0 Q

 S IOP="`"_$P(Y,"^",3),PSGSPD=$P(Y,"^",2) F  W !,"Do you want to dispense ",$S(PSGEUD>1:"these",1:"this")," extra unit",$E("s",PSGEUD>1)," through the ATC" S %=2 D YN^DICN Q:%  D QSH

 S Y=0 Q:%'=1  K %ZIS,IO("Q") S %ZIS="NQ",PSGION=ION,IOP=IOP_";255" D ^%ZIS I POP S IOP=PSGION D ^%ZIS W $C(7),!!?10,"** THE ATC MACHINE CANNOT BE FOUND! **" S Y=0 Q

 K ZTSAVE S PSGTIR="ENQ^PSGEUD",PSGTID=$H,ZTDESC="EXTRA UNITS TO ATC" F X="PSGP","PSGORD","PSGP(0)","PSGSPD" S ZTSAVE(X)=""

 D ENTSK^PSGTI W "...DONE" S Y=0 Q

 ;

ENQ ;

 D NOW^%DTC S DFN=PSGP D PID^VADPT

 S %=%_"0000000000000",BLKS="                    ",PN=$E($P(PSGP(0),"^")_BLKS,1,20),PID=$E(VA("PID")_BLKS,1,12),PL=$E($S($D(^DPT(PSGP,.1)):^(.1),1:"*N/F*")_BLKS,1,12)

 X ^%ZOSF("LABOFF") F PSGDRG=0:0 S PSGDRG=$O(^PS(55,PSGP,5,+PSGORD,1,PSGDRG)) Q:'PSGDRG  S X=$G(^(PSGDRG,0)) I X D

 .S C=$P(X,U,11),PSGEUDA=$P($G(^PSDRUG(+X,8.5)),U,2) Q:(PSGEUDA="")!('C)

 .S PSGEUDA=$E(PSGEUDA_BLKS,1,15) S:$L(C)<3 C=$E("000",1,3-$L(C))_C S C=C_$E(%,4,5)_$E(%,6,7)_$E(%,2,3)_$E(%,9,10)_$E(%,11,12) D @$S(PSGSPD:"S2",1:"S1")

 Q

 ;

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  Q

 W $C(50),$C(52),PN_PID_PL_"IMD"_PSGEUDA_"1 ",$C(53),$C(54),C,$C(55),$C(13) F Q=1:1:75 R *X:$S(Q<15:1,1:5) G:X=49 S1 I X=48 Q

 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  Q

 W $C(50),$C(52),PN_PID_PL_"IMD"_PSGEUDA_"1 ",$C(53),$C(54),C,$C(55),$C(13) F Q=1:1:75 R X:$S(Q<15:1,1:5) G:$A(X)=49 S2 I $A(X)=48 Q

 Q

 ;

QSH ;

 W !!?2,"This drug can be dispensed through the ATC machine.  Enter 'Y' to do so now.  Enter 'N' if you do not want to do so.",! Q

 ;

H ;

 W !!?2,"Select the orders (by number) for which you want to enter extra units",!,"dispensed." D:X'="?" H2^PSGON

 Q

PSGEUD    ;BIR/CML3-EXTRA UNITS DISPENSED ;17 SEP 97 /  1:41 PM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**31,41,50,111,150,164**;16 DEC 97

 +2       ;

 +3       ; Reference to ^PSDRUG( is supported by DBIA 2192.

 +4       ; Reference to ^PS(50.7 is supported by DBIA 2180.

 +5       ; Reference to ^PS(51.2 is supported by DBIA 2178.

 +6       ; Reference to ^PS(55 is supported by DBIA 2191.

 +7       ;

 +8        NEW PSJNEW,PSGPTMP,PPAGE,PSGEFN

           SET PSJNEW=1

 +9        DO ENCV^PSGSETU

           IF $DATA(XQUIT)

               QUIT 

           SET (PSGONNV,PSGRETF)=1

           KILL PSGPRP

 +10      ;

GP        ;

 +1        SET PSGP=""

           SET DFN=""

 +2        DO ENDPT^PSGP

           IF (PSGP'>0)&(DFN'>0)!('$DATA(PSJPAD))

               GOTO DONE

           IF PSGP<1

               SET PSGP=DFN

           IF '$ORDER(^PS(55,PSGP,5,"AUS",+PSJPAD))

               WRITE $CHAR(7),!,"(Patient has NO active or old orders.)"

               GOTO GP

 +3        DO ENL^PSGOU

           IF "^N"[PSGOL

               GOTO GP

           SET PSGPTMP=0

           SET PPAGE=1

           DO ^PSGO

           IF 'PSGON

               GOTO GP

           SET PSGLMT=PSGON

           SET (PSGONC,PSGONR)=0

 +4        FOR 

               WRITE !!,"Select ORDER",$EXTRACT("S",PSGON>1)," 1-",PSGON,": "

               READ X:DTIME

               IF '$TEST

                   WRITE $CHAR(7)

               IF '$TEST

                   SET X="^"

               IF "^"[X

                   QUIT 

               IF X?1."?"

                   DO H

               IF X'?1."?"

                   DO ENCHK^PSGON

                   IF '$DATA(X)

                       WRITE $CHAR(7),"  ??"

                   IF $DATA(X)

                       QUIT 

 +5        IF "^"[X

               GOTO GP

           FOR PSGRET=1:1:PSGODDD

               FOR PSGRET1=1:1

                   SET PSGRET2=$PIECE(PSGODDD(PSGRET),",",PSGRET1)

                   IF 'PSGRET2

                       QUIT 

                   SET PSGORD=^TMP("PSJON",$JOB,PSGRET2)

                   DO R

                   IF $DATA(DTOUT)

                       GOTO GP

 +6        GOTO GP

 +7       ;

DONE      ;

 +1        DO ENKV^PSGSETU

           KILL ^TMP("PSJON",$JOB),DO,DRGN,MR,OD,PSGLMT,PSGODDD,PSGEUD,PSGEUDA,PSGOL,PSGON,PSGONC,PSGONR,PSGONV,PSGONNV,PSGORD,PSGQ,PSGRET,PSGRET1,PSGRET2,PSGRETF,PSGSPD,SCH,WG,Z,CST

           QUIT 

 +2       ;

R         ;

 +1        SET MR=$PIECE($GET(^PS(55,PSGP,5,+PSGORD,0)),"^",3)

           SET Y=$GET(^(.2))

           SET SCH=$PIECE($GET(^(2)),"^")

           SET DO=$PIECE(Y,"^",2)

           SET DRG=$PIECE(Y,"^")

           SET DRG=$SELECT(DRG'=+DRG:"NOT FOUND",'$DATA(^PS(50.7,DRG,0)):DRG,$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:DRG_";PS(50.7,")

 +2        IF MR]""

               SET MR=$SELECT(MR'=MR:MR,'$DATA(^PS(51.2,MR,0)):MR,$PIECE(^(0),"^",3)]"":$PIECE(^(0),"^",3),$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:MR_";PS(51.2,")

           WRITE !!,"----------------------------------------",!,DRG,!,"Give: "

           Begin DoDot:1

 +3            NEW LN,MARX

               DO TXT^PSGMUTL(DO_" "_MR_" "_SCH,65)

 +4            SET LN=""

               FOR 

                   SET LN=$ORDER(MARX(LN))

                   IF LN=""

                       QUIT 

                   IF LN>1

                       WRITE !

                   WRITE ?6,MARX(LN)

           End DoDot:1

 +5        IF '$ORDER(^PS(55,PSGP,5,+PSGORD,1,0))

               Begin DoDot:1

 +6                WRITE !!,"No Dispense drugs have been entered for this order. At least one Dispense drugs",!,"must be associated with an order before dispensing information may be entered.",!!

 +7                NEW DIR

                   SET DIR(0)="E"

                   DO ^DIR

                   SET Y=$SELECT(Y:0,1:1)

               End DoDot:1

               QUIT 

 +8        SET PSGEUD=0

           SET WG=$ORDER(^PS(57.5,"AB",+PSJPWD,0))

           FOR DRG=0:0

               SET DRG=$ORDER(^PS(55,PSGP,5,+PSGORD,1,DRG))

               IF 'DRG

                   QUIT 

               SET X=$GET(^(DRG,0))

               IF X

                   Begin DoDot:1

 +9                    SET UD=$PIECE(X,"^",2)

                       SET DRGN=$$ENDDN^PSGMI(+X)

                       IF DRGN=""

                           QUIT 

                       IF '$DATA(^PSDRUG(+X,212,"AC",+WG))

                           SET WG=""

 +10                   IF ($PIECE(X,"^",3)?7N)&($PIECE(PSGDT,".")'<$PIECE(X,"^",3))

                           WRITE !!,"Dispense drug: ",DRGN," **ORDER INACTIVE**"

                           QUIT 

 +11                   IF ($GET(^PSDRUG(+X,"I"))?7N)&($PIECE(PSGDT,".")'<$GET(^PSDRUG(+X,"I")))

                           WRITE !!,"Dispense drug: ",DRGN," **DRUG INACTIVE**"

                           QUIT 

 +12                   WRITE !!,"Dispense drug: ",DRGN,"  (U/D: ",$SELECT('UD:1,1:UD),")"

 +13                   KILL DA,DR

                       SET DA=+DRG

                       SET DA(2)=PSGP

                       SET DA(1)=+PSGORD

                       SET DIE="^PS(55,"_PSGP_",5,"_+PSGORD_",1,"

                       SET DR=.11

                       IF $PIECE($GET(^PS(55,PSGP,5,+PSGORD,1,DA,0)),"^",11)

                           SET $PIECE(^(0),"^",11)=""

 +14                   DO ^DIE

                       SET PSGEUD=PSGEUD+$PIECE($GET(^PS(55,PSGP,5,+PSGORD,1,DA,0)),U,11)

                   End DoDot:1

                   IF $DATA(DTOUT)

                       QUIT 

 +15       IF PSGEUD

               IF WG

                   DO QS

 +16       QUIT 

 +17      ;

QS        ;

 +1        WRITE !!,"THIS DRUG IS AN ATC ITEM."

           SET Y=$GET(^PS(57.5,WG,3))

           IF $PIECE(Y,"^",3)=""

               WRITE $CHAR(7),"  BUT THE ATC DEVICE CANNOT BE FOUND!"

               SET Y=0

               QUIT 

 +2        SET IOP="`"_$PIECE(Y,"^",3)

           SET PSGSPD=$PIECE(Y,"^",2)

           FOR 

               WRITE !,"Do you want to dispense ",$SELECT(PSGEUD>1:"these",1:"this")," extra unit",$EXTRACT("s",PSGEUD>1)," through the ATC"

               SET %=2

               DO YN^DICN

               IF %

                   QUIT 

               DO QSH

 +3        SET Y=0

           IF %'=1

               QUIT 

           KILL %ZIS,IO("Q")

           SET %ZIS="NQ"

           SET PSGION=ION

           SET IOP=IOP_";255"

           DO ^%ZIS

           IF POP

               SET IOP=PSGION

               DO ^%ZIS

               WRITE $CHAR(7),!!?10,"** THE ATC MACHINE CANNOT BE FOUND! **"

               SET Y=0

               QUIT 

 +4        KILL ZTSAVE

           SET PSGTIR="ENQ^PSGEUD"

           SET PSGTID=$HOROLOG

           SET ZTDESC="EXTRA UNITS TO ATC"

           FOR X="PSGP","PSGORD","PSGP(0)","PSGSPD"

               SET ZTSAVE(X)=""

 +5        DO ENTSK^PSGTI

           WRITE "...DONE"

           SET Y=0

           QUIT 

 +6       ;

ENQ       ;

 +1        DO NOW^%DTC

           SET DFN=PSGP

           DO PID^VADPT

 +2        SET %=%_"0000000000000"

           SET BLKS="                    "

           SET PN=$EXTRACT($PIECE(PSGP(0),"^")_BLKS,1,20)

           SET PID=$EXTRACT(VA("PID")_BLKS,1,12)

           SET PL=$EXTRACT($SELECT($DATA(^DPT(PSGP,.1)):^(.1),1:"*N/F*")_BLKS,1,12)

 +3        XECUTE ^%ZOSF("LABOFF")

           FOR PSGDRG=0:0

               SET PSGDRG=$ORDER(^PS(55,PSGP,5,+PSGORD,1,PSGDRG))

               IF 'PSGDRG

                   QUIT 

               SET X=$GET(^(PSGDRG,0))

               IF X

                   Begin DoDot:1

 +4                    SET C=$PIECE(X,U,11)

                       SET PSGEUDA=$PIECE($GET(^PSDRUG(+X,8.5)),U,2)

                       IF (PSGEUDA="")!('C)

                           QUIT 

 +5                    SET PSGEUDA=$EXTRACT(PSGEUDA_BLKS,1,15)

                       IF $LENGTH(C)<3

                           SET C=$EXTRACT("000",1,3-$LENGTH(C))_C

                       SET C=C_$EXTRACT(%,4,5)_$EXTRACT(%,6,7)_$EXTRACT(%,2,3)_$EXTRACT(%,9,10)_$EXTRACT(%,11,12)

                       DO @$SELECT(PSGSPD:"S2",1:"S1")

                   End DoDot:1

 +6        QUIT 

 +7       ;

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

               QUIT 

 +3        WRITE $CHAR(50),$CHAR(52),PN_PID_PL_"IMD"_PSGEUDA_"1 ",$CHAR(53),$CHAR(54),C,$CHAR(55),$CHAR(13)

           FOR Q=1:1:75

               READ *X:$SELECT(Q<15:1,1:5)

               IF X=49

                   GOTO S1

               IF X=48

                   QUIT 

 +4        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

               QUIT 

 +3        WRITE $CHAR(50),$CHAR(52),PN_PID_PL_"IMD"_PSGEUDA_"1 ",$CHAR(53),$CHAR(54),C,$CHAR(55),$CHAR(13)

           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        QUIT 

 +5       ;

QSH       ;

 +1        WRITE !!?2,"This drug can be dispensed through the ATC machine.  Enter 'Y' to do so now.  Enter 'N' if you do not want to do so.",!

           QUIT 

 +2       ;

H         ;

 +1        WRITE !!?2,"Select the orders (by number) for which you want to enter extra units",!,"dispensed."

           IF X'="?"

               DO H2^PSGON

 +2        QUIT