PSJO.m

PSJO ;BIR/CML3,PR-GET AND PRINT INPATIENT ORDERS ;28 Jun 99 / 10:20 AM

 ;;5.0; INPATIENT MEDICATIONS ;**31,58,110**;16 DEC 97

 ;

 ; Reference to ^PSD(58.8 supported by DBIA #2283.

 ; Reference to ^PSI(58.1 supported by DBIA #2284.

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

 ;

 K ^TMP("PSJON",$J),^TMP("PSJ",$J) D @$S($D(PSJEXTP):"EN^PSJH1",1:"EN^PSJO1(3)")

 S PSJDEV=IO'=IO(0)!($E(IOST,1,2)'="C-"),(NP,PSGON,PSJON)=""

 U IO D ENGET^PSJO3 I '$D(^TMP("PSJ",$J)) W !,SLS,SLS,$E(SLS,1,25),!!?22,"NO ORDERS FOUND FOR ",$S(PSJOL="S":"SHORT",1:"LONG")," PROFILE."

 E  S (PSJC,PSJS,PSJO,PSJST)="" F  S PSJC=$O(^TMP("PSJ",$J,PSJC)) Q:PSJC=""  D  G:NP["^" DONE

 .D:$S((PSJC["B"&'TF):0,PSJC'["A":1,1:1) TF

 .F  S PSJST=$O(^TMP("PSJ",$J,PSJC,PSJST)) Q:PSJST=""  F  S PSJS=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS)) Q:PSJS=""!(NP[U)  D ON

 G:NP[U DONE I PSJDEV,$S('$D(PSJPRP):1,1:PSJPRP="P") D BOT

 ;

DONE ;

 I $S('$D(PSJPRP):1,1:PSJPRP="P") K ^TMP("PSJ",$J)

 S PSGON=PSJON K:'$D(PSGVBW) PSGODT K %,%H,%I,C,DN,DO,DRG,FQ,GIVE,HDT,I,JJ,LN2,N,ND,ND4,ND6,NF,NP,O,ON,ORIFN,ORTX,P,PF,PG,PS,PSGID,PSGOD,PSIVSC,PSIVST,PSIVTY,PSJC,PSJDEV,PSJF,PSJO,PSJOS,PSJS,PSJSCHT,PSJST,QQ,RB,RTE,SCH,SD,SLS,SM

 K ST,START,STAT,SUB,TF,TYP,UDU,UPD,V,WS,X,X1,X2,Y Q

 ;

ON ;

 S PSJSCHT=$S(PSJOS:PSJS,1:PSJST)

 F FQ=0:0 S PSJO=$O(^TMP("PSJ",$J,PSJC,PSJST,PSJS,PSJO)) Q:PSJO=""  S DN=^(PSJO) D:$Y+6>IOSL ENNP^PSJO3 Q:NP["^"  D  ;

 .S PSJON=PSJON+1 S:'PSJDEV ^TMP("PSJON",$J,PSJON)=PSJO W !,$J(PSJON,4),?5 D @$S(PSJO["V":"PIV^PSIVUTL(PSJO)",PSJO["U":"PUD",1:"PIV^PSIVUTL(PSJO)")

 Q

 ;

PUD ; print unit dose

 ; Naked reference below refers to full reference ^PS(53.1,+PSJO,0) or ^PS(55,DFN,5,+PSJO,0) using indirection.

 S ND=$S($D(@(PSJF_+PSJO_",0)")):^(0),1:""),SCH=$G(^(2)),ND4=$G(^(4)),ND6=$P($G(^(6)),"^"),DO=$S($P(DN,"^",2)=.2:$P($G(@(PSJF_+PSJO_",.2)")),"^",2),1:$G(@(PSJF_+PSJO_",.3)")))

 ;I PSJC["A" S V='$P(ND4,"^",UDU) W $S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",18)&($P(ND4,"^",19)!V):"H",$P(ND4,"^",22)&($P(ND4,"^",23)!V):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" ") W:V&(PSJSYSU) "->"

 I "AO"[PSJC D

 .S V='$P(ND4,"^",UDU),V=$S(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)

 .W $S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",18)&($P(ND4,"^",19)!V):"H",$P(ND4,"^",22)&($P(ND4,"^",23)!V):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" ")

 .W $S($P($G(@(PSJF_+PSJO_",.2)")),"^",4)="D":"d",1:" ")_$S(V:"->",1:"  ")

 ;I $S(PSJC["NZ":0,1:PSJC["N") W $S($P(ND4,"^",12):"D",1:" "),$S(PSJSYSU:"->",1:"")

 I $S(PSJC["NZ":0,1:PSJC["N") W $S($P(ND4,"^",12):"D",1:" ")

 S RTE=$P(ND,"^",3),SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2),STAT=$S($P(ND,"^",9)]"":$P(ND,"^",9),1:"NF"),PF=$E("*",$P(ND,"^",20)>0),PSGID=$P(SCH,"^",2),SD=$P(SCH,"^",4),SCH=$P(SCH,"^")

 I STAT="A",$P(ND,U,27)="R" S STAT="R"

 S NF=$P(DN,"^",2),WS=$S(PSJPWD:$$WS(PSJPWD,PSGP,PSJF,PSJO),1:0)

 NEW MARX,PSJRNDT

 S PSJRNDT=$$LASTREN^PSJLMPRI(DFN,PSJO) S:PSJRNDT PSJRNDT=$E($$ENDTC^PSGMI(+PSJRNDT),1,5)

 D DRGDISP^PSJLMUT1(PSGP,+PSJO_$S(PSJC["A":"U",PSJC["O":"U",1:"P"),40,54,.MARX,0)

 F X=0:0 S X=$O(MARX(X)) Q:'X  W @($S(X=1:"?9",1:"!?11")),$S($E(PSJS)="*":$P(PSJS,"^"),1:MARX(X)) D:X=1

 . W ?50,$S(PSJC["NZ":"?",PSJSCHT'="z":PSJSCHT,1:"?")

 . W:'$D(PSJEXTP) ?53,$S(PSJC["NZ":"*****",1:$E($$ENDTC^PSGMI(PSGID),1,5)),?60,$S(PSJC["NZ":"*****",1:$E($$ENDTC^PSGMI(SD),1,5)),?67,STAT

 . W:$D(PSJEXTP) ?53,$S(PSJC["NZ":"*****",1:$E($$ENDTC^PSGMI(PSGID),1,8)),?63,$S(PSJC["NZ":"*****",1:$E($$ENDTC^PSGMI(SD),1,8)),?73,STAT

 . I NF!WS!SM!PF!(PSJRNDT]"") W ?71 W:NF "NF " W:WS "WS " W:SM $E("HSM",SM,3) W:$G(PSJRNDT) PSJRNDT W:PF ?79,"*"

 I ND6]"" S Y=$$ENSET^PSGSICHK(ND6) W !?11 F X=1:1:$L(Y," ") S V=$P(Y," ",X) W:$L(V)+$X>66 !?11 W V_" "

 Q

 ;

TF ;

 NEW SLS,C S SLS="",C=PSJC,$P(SLS," -",40)=""

 S LN2=$S(C="A":"A C T I V E",C["CC":"P E N D I N G   R E N E W A L S",C["CD":"P E N D I N G   C O M P L E X",C["BD":"N O N - V E R I F I E D  C O M P L E X",C["C":"P E N D I N G ",C["B":"N O N - V E R I F I E D",1:"N O N - A C T I V E")

 W:$D(^TMP("PSJ",$J,PSJC)) !,$E($E(SLS,1,(80-$L(LN2))/2)_" "_LN2_$E(SLS,1,(80-$L(LN2))/2),1,80)

 S PSJF="^PS("_$S(PSJC'["C":"55,"_PSGP_",5,",1:"53.1,") S TF=$S(PSJC["C":0,1:TF)

 Q

 ;

 ;

BOT ; print name, ssn, and dob on bottom of page

 F Q=$Y:1:IOSL-4 W !

 W !,?2,$P(PSGP(0),"^"),?40,PSJPPID,?70,$E($P(PSJPDOB,"^",2),1,8)

 Q

WS(PSJPWD,PSGP,PSJF,PSJO) ; - WARD STOCK flag, input=(ward,dfn,file root,order)

 ; Naked reference below refers to full reference ^PS(55,DFN,5,+PSJO,1,"B",PSWS) using indirection.

 S WS=0,PSJF=PSJF_+PSJO_",1,""B"")" I $D(@PSJF) N PSWS S PSWS=0 F  S PSWS=$O(^("B",PSWS)) Q:'PSWS  S WS=$$WSCHK(PSJPWD,PSWS) Q:WS

 Q WS

 ;

WSCHK(PSJPWD,PSWS) ; Determine if drug is ward stock item.

 Q $S(PSJPWD:$S($D(^PSI(58.1,"D",PSWS,PSJPWD)):1,$D(^PSD(58.8,"D",PSWS,PSJPWD)):1,1:0),1:0)

PSJO      ;BIR/CML3,PR-GET AND PRINT INPATIENT ORDERS ;28 Jun 99 / 10:20 AM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**31,58,110**;16 DEC 97

 +2       ;

 +3       ; Reference to ^PSD(58.8 supported by DBIA #2283.

 +4       ; Reference to ^PSI(58.1 supported by DBIA #2284.

 +5       ; Reference to ^PS(55 supported by DBIA #2191.

 +6       ;

 +7        KILL ^TMP("PSJON",$JOB),^TMP("PSJ",$JOB)

           DO @$SELECT($DATA(PSJEXTP):"EN^PSJH1",1:"EN^PSJO1(3)")

 +8        SET PSJDEV=IO'=IO(0)!($EXTRACT(IOST,1,2)'="C-")

           SET (NP,PSGON,PSJON)=""

 +9        USE IO

           DO ENGET^PSJO3

           IF '$DATA(^TMP("PSJ",$JOB))

               WRITE !,SLS,SLS,$EXTRACT(SLS,1,25),!!?22,"NO ORDERS FOUND FOR ",$SELECT(PSJOL="S":"SHORT",1:"LONG")," PROFILE."

 +10      IF '$TEST

               SET (PSJC,PSJS,PSJO,PSJST)=""

               FOR 

                   SET PSJC=$ORDER(^TMP("PSJ",$JOB,PSJC))

                   IF PSJC=""

                       QUIT 

                   Begin DoDot:1

 +11                   IF $SELECT((PSJC["B"&'TF)

                           DO TF

 +12                   FOR 

                           SET PSJST=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST))

                           IF PSJST=""

                               QUIT 

                           FOR 

                               SET PSJS=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST,PSJS))

                               IF PSJS=""!(NP[U)

                                   QUIT 

                               DO ON

                   End DoDot:1

                   IF NP["^"

                       GOTO DONE

 +13       IF NP[U

               GOTO DONE

           IF PSJDEV

               IF $SELECT('$DATA(PSJPRP):1,1:PSJPRP="P")

                   DO BOT

 +14      ;

DONE      ;

 +1        IF $SELECT('$DATA(PSJPRP):1,1:PSJPRP="P")

               KILL ^TMP("PSJ",$JOB)

 +2        SET PSGON=PSJON

           IF '$DATA(PSGVBW)

               KILL PSGODT

           KILL %,%H,%I,C,DN,DO,DRG,FQ,GIVE,HDT,I,JJ,LN2,N,ND,ND4,ND6,NF,NP,O,ON,ORIFN,ORTX,P,PF,PG,PS,PSGID,PSGOD,PSIVSC,PSIVST,PSIVTY,PSJC,PSJDEV,PSJF,PSJO,PSJOS,PSJS,PSJSCHT,PSJST,QQ,RB,RTE,SCH,SD,SLS,SM

 +3        KILL ST,START,STAT,SUB,TF,TYP,UDU,UPD,V,WS,X,X1,X2,Y

           QUIT 

 +4       ;

ON        ;

 +1        SET PSJSCHT=$SELECT(PSJOS:PSJS,1:PSJST)

 +2       ;

           FOR FQ=0:0

               SET PSJO=$ORDER(^TMP("PSJ",$JOB,PSJC,PSJST,PSJS,PSJO))

               IF PSJO=""

                   QUIT 

               SET DN=^(PSJO)

               IF $Y+6>IOSL

                   DO ENNP^PSJO3

               IF NP["^"

                   QUIT 

               Begin DoDot:1

 +3                SET PSJON=PSJON+1

                   IF 'PSJDEV

                       SET ^TMP("PSJON",$JOB,PSJON)=PSJO

                   WRITE !,$JUSTIFY(PSJON,4),?5

                   DO @$SELECT(PSJO["V":"PIV^PSIVUTL(PSJO)",PSJO["U":"PUD",1:"PIV^PSIVUTL(PSJO)")

               End DoDot:1

 +4        QUIT 

 +5       ;

PUD       ; print unit dose

 +1       ; Naked reference below refers to full reference ^PS(53.1,+PSJO,0) or ^PS(55,DFN,5,+PSJO,0) using indirection.

 +2        SET ND=$SELECT($DATA(@(PSJF_+PSJO_",0)")):^(0),1:"")

           SET SCH=$GET(^(2))

           SET ND4=$GET(^(4))

           SET ND6=$PIECE($GET(^(6)),"^")

           SET DO=$SELECT($PIECE(DN,"^",2)=.2:$PIECE($GET(@(PSJF_+PSJO_",.2)")),"^",2),1:$GET(@(PSJF_+PSJO_",.3)")))

 +3       ;I PSJC["A" S V='$P(ND4,"^",UDU) W $S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",18)&($P(ND4,"^",19)!V):"H",$P(ND4,"^",22)&($P(ND4,"^",23)!V):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" ") W:V&(PSJSYSU) "->"

 +4        IF "AO"[PSJC

               Begin DoDot:1

 +5                SET V='$PIECE(ND4,"^",UDU)

                   SET V=$SELECT(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)

 +6                WRITE $SELECT(ND4="":" ",$PIECE(ND4,"^",12):"D",$PIECE(ND4,"^",18)&($PIECE(ND4,"^",19)!V):"H",$PIECE(ND4,"^",22)&($PIECE(ND4,"^",23)!V):"H",$PIECE(ND4,"^",15)&($PIECE(ND4,"^",16)!V):"R",1:" ")

 +7                WRITE $SELECT($PIECE($GET(@(PSJF_+PSJO_",.2)")),"^",4)="D":"d",1:" ")_$SELECT(V:"->",1:"  ")

               End DoDot:1

 +8       ;I $S(PSJC["NZ":0,1:PSJC["N") W $S($P(ND4,"^",12):"D",1:" "),$S(PSJSYSU:"->",1:"")

 +9        IF $SELECT(PSJC["NZ":0,1:PSJC["N")

               WRITE $SELECT($PIECE(ND4,"^",12):"D",1:" ")

 +10       SET RTE=$PIECE(ND,"^",3)

           SET SM=$SELECT('$PIECE(ND,"^",5):0,$PIECE(ND,"^",6):1,1:2)

           SET STAT=$SELECT($PIECE(ND,"^",9)]"":$PIECE(ND,"^",9),1:"NF")

           SET PF=$EXTRACT("*",$PIECE(ND,"^",20)>0)

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

           SET SD=$PIECE(SCH,"^",4)

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

 +11       IF STAT="A"

               IF $PIECE(ND,U,27)="R"

                   SET STAT="R"

 +12       SET NF=$PIECE(DN,"^",2)

           SET WS=$SELECT(PSJPWD:$$WS(PSJPWD,PSGP,PSJF,PSJO),1:0)

 +13       NEW MARX,PSJRNDT

 +14       SET PSJRNDT=$$LASTREN^PSJLMPRI(DFN,PSJO)

           IF PSJRNDT

               SET PSJRNDT=$EXTRACT($$ENDTC^PSGMI(+PSJRNDT),1,5)

 +15       DO DRGDISP^PSJLMUT1(PSGP,+PSJO_$SELECT(PSJC["A":"U",PSJC["O":"U",1:"P"),40,54,.MARX,0)

 +16       FOR X=0:0

               SET X=$ORDER(MARX(X))

               IF 'X

                   QUIT 

               WRITE @($SELECT(X=1:"?9",1:"!?11")),$SELECT($EXTRACT(PSJS)="*":$PIECE(PSJS,"^"),1:MARX(X))

               IF X=1

                   Begin DoDot:1

 +17                   WRITE ?50,$SELECT(PSJC["NZ":"?",PSJSCHT'="z":PSJSCHT,1:"?")

 +18                   IF '$DATA(PSJEXTP)

                           WRITE ?53,$SELECT(PSJC["NZ":"*****",1:$EXTRACT($$ENDTC^PSGMI(PSGID),1,5)),?60,$SELECT(PSJC["NZ":"*****",1:$EXTRACT($$ENDTC^PSGMI(SD),1,5)),?67,STAT

 +19                   IF $DATA(PSJEXTP)

                           WRITE ?53,$SELECT(PSJC["NZ":"*****",1:$EXTRACT($$ENDTC^PSGMI(PSGID),1,8)),?63,$SELECT(PSJC["NZ":"*****",1:$EXTRACT($$ENDTC^PSGMI(SD),1,8)),?73,STAT

 +20                   IF NF!WS!SM!PF!(PSJRNDT]"")

                           WRITE ?71

                           IF NF

                               WRITE "NF "

                           IF WS

                               WRITE "WS "

                           IF SM

                               WRITE $EXTRACT("HSM",SM,3)

                           IF $GET(PSJRNDT)

                               WRITE PSJRNDT

                           IF PF

                               WRITE ?79,"*"

                   End DoDot:1

 +21       IF ND6]""

               SET Y=$$ENSET^PSGSICHK(ND6)

               WRITE !?11

               FOR X=1:1:$LENGTH(Y," ")

                   SET V=$PIECE(Y," ",X)

                   IF $LENGTH(V)+$X>66

                       WRITE !?11

                   WRITE V_" "

 +22       QUIT 

 +23      ;

TF        ;

 +1        NEW SLS,C

           SET SLS=""

           SET C=PSJC

           SET $PIECE(SLS," -",40)=""

 +2        SET LN2=$SELECT(C="A":"A C T I V E",C["CC":"P E N D I N G   R E N E W A L S",C["CD":"P E N D I N G   C O M P L E X",C["BD":"N O N - V E R I F I E D  C O M P L E X",C["C":"P E N D I N G ",C["B":"N O N - V E R I F I E D",1:"N O N - A C T I V E")

 +3        IF $DATA(^TMP("PSJ",$JOB,PSJC))

               WRITE !,$EXTRACT($EXTRACT(SLS,1,(80-$LENGTH(LN2))/2)_" "_LN2_$EXTRACT(SLS,1,(80-$LENGTH(LN2))/2),1,80)

 +4        SET PSJF="^PS("_$SELECT(PSJC'["C":"55,"_PSGP_",5,",1:"53.1,")

           SET TF=$SELECT(PSJC["C":0,1:TF)

 +5        QUIT 

 +6       ;

 +7       ;

BOT       ; print name, ssn, and dob on bottom of page

 +1        FOR Q=$Y:1:IOSL-4

               WRITE !

 +2        WRITE !,?2,$PIECE(PSGP(0),"^"),?40,PSJPPID,?70,$EXTRACT($PIECE(PSJPDOB,"^",2),1,8)

 +3        QUIT 

WS(PSJPWD,PSGP,PSJF,PSJO) ; - WARD STOCK flag, input=(ward,dfn,file root,order)

 +1       ; Naked reference below refers to full reference ^PS(55,DFN,5,+PSJO,1,"B",PSWS) using indirection.

 +2        SET WS=0

           SET PSJF=PSJF_+PSJO_",1,""B"")"

           IF $DATA(@PSJF)

               NEW PSWS

               SET PSWS=0

               FOR 

                   SET PSWS=$ORDER(^("B",PSWS))

                   IF 'PSWS

                       QUIT 

                   SET WS=$$WSCHK(PSJPWD,PSWS)

                   IF WS

                       QUIT 

 +3        QUIT WS

 +4       ;

WSCHK(PSJPWD,PSWS) ; Determine if drug is ward stock item.

 +1        QUIT $SELECT(PSJPWD:$SELECT($DATA(^PSI(58.1,"D",PSWS,PSJPWD)):1,$DATA(^PSD(58.8,"D",PSWS,PSJPWD)):1,1:0),1:0)