- PSGO ;BIR/CML3,MV - PRINTS PATIENT'S ORDERS ;Jul 12, 2018@13:10
- ;;5.0;INPATIENT MEDICATIONS;**4,58,110,181,275,373**;16 DEC 97;Build 3
- ;
- ; Reference to ^PS(55 is supported by DBIA #2191.
- ;
- K ^TMP("PSJON",$J),PSGONF S PSGOH="U N I T D O S E P R O F I L E" D ENGORD^PSGOU
- ;
- EN ;
- N TF2 S TF2=""
- S CML=IO'=IO(0)!($E(IOST,1,2)'="C-"),NP="" N RB
- U IO D GET I '$D(^TMP("PSG",$J)) W !,SLS,SLS,$E(SLS,1,24),!?22,"NO ORDERS FOUND" W:"SL"[PSGOL " FOR A ",$S(PSGOL="S":"SHORT",1:"LONG")," PROFILE."
- G:NP["^" DONE
- E S (C,DRG)="",LD=0
- E D DRG G:NP["^" DONE
- I CML,$S('$D(PSGPRP):1,1:PSGPRP="P") D BOT
- ;
- DONE ;
- I $S('$D(PSGPRP):1,1:PSGPRP="P") K ^TMP("PSG",$J)
- S PSGON=$S('CML:ON,1:0) K:'$D(PSGVBW) PSGODT
- ;
- D1 ;
- K C,CML,DN,DO,DRG,F,GIVE,HDT,LN2,NF,ND,ND4,ND6,NP,O,ON,PF,PG,PSGHD,PSGOH,PSJTEAM,RCT,RF,RTE,S,SCH,SD,SLS,SM,ST,STS,TF,UDU,V,WD,WS,WT Q
- ;
- DRG ;
- I PSGOL'="N" F S C=$O(^TMP("PSG",$J,C)) Q:C=""!(NP["^") D:$S(($P(C,"^")="Cz")&(TF2'=$P(C,"^",2)):1,C="BA":1,C="CC":1,C="CD":1,C["C":TF,1:1) TF F ST="C","O","OC","P","R","z" D
- .F S DRG=$O(^TMP("PSG",$J,C,ST,DRG)) Q:DRG=""!(NP["^") S NF=^(DRG),O=$P(DRG,"^",2),DN=$P(DRG,"^") D:$Y+4>IOSL NP Q:NP["^" D P
- I PSGOL="N" F S LD=$O(^TMP("PSG",$J,LD)) Q:'LD S X=^(LD),NF=$P(X,U),C=$P(X,U,2),ST=$P(X,U,3),DN=$P(X,U,4),O=$P(LD,U,2) D P
- Q
- ;
- P ;Display drug data stored in ^TMP("PSG",$J
- I $G(O)["U"&($P(C,"^",4)="A") N F S F="^PS(55,PSGP,5,"
- S ON=ON+1 I 'CML D
- .N PSJOSUFX I ($P(C,"^")="Cz") S PSJOSUFX=$S(($P(C,"^",4))["CD":"",($P(C,"^",4)["C"):"P",($P(C,"^",4)["BD"):"",($P(C,"^",4)["B"):"P",1:"U")
- .I ($P(C,"^")'="Cz") S PSJOSUFX=$S(C["CD":"",C["C":"P",C["BD":"",C["B":"P",1:"U")
- .S ^TMP("PSJON",$J,ON)=+O_PSJOSUFX
- .S:(C'["O"&($P(C,"^")'="Cz")) PSGONC=ON S:($P(C,"^")="Cz"&($P(C,"^",4)'["O")) PSGONC=ON
- Q:PSGOL="N"
- W !,$J(ON,4),?5
- I (C["CD"&($P(C,"^")'="Cz"))!($P(C,"^",4)["CD") N PSJO,OO S PSJO=O,OO=0 F S OO=$O(^PS(53.1,"ACX",PSJO,OO)) Q:'OO S O=OO D P2 W !
- I (C["BD"&($P(C,"^")'="Cz"))!($P(C,"^",4)["BD") N PSJO,OO S PSJO=O,OO=0 F S OO=$O(^PS(53.1,"ACX",PSJO,OO)) Q:'OO S O=OO D P2 W !
- Q:(C["BD"&($P(C,"^")'="Cz")) Q:(C["CD"&($P(C,"^")'="Cz")) Q:($P(C,"^",4)["BD") Q:($P(C,"^",4)["CD")
- ; naked references below refer to full reference inside indirection @(F_+O_".0)" for either file 53.1 or 55
- P2 S ND=$G(@(F_+O_",0)")),SCH=$G(^(2)),ND4=$G(^(4)),ND6=$G(^(6)),DO=$G(^(.2))
- I (C="A"!($P(C,"^",4)="A")),PSJSYSU,'$P(ND4,"^",+PSJSYSU),$P(ND4,"^",+PSJSYSU=1+9) S PSGONV=ON
- I (C="A"!(C="O"))!(($P(C,"^",4)="A")!($P(C,"^",4)="O")) S:$P(ND,"^",9)'="H"&'CML PSGONR=ON 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",V!$P(ND4,"^",19)&$P(ND4,"^",18):"H",V!$P(ND4,"^",23)&$P(ND4,"^",22):"H",V!$P(ND4,"^",16)&$P(ND4,"^",15):"R",1:" ")
- .W $S($P(DO,U,4)="D":"d",1:" ")_$S(V:"->",1:" ")
- I ($P(C,"^")="Cz")&(($P(C,"^",4)="CA")!($P(C,"^",4)["B")) W $S($P(ND4,"^",12):"D",1:" ") I ($P(C,"^",4)["B") S PSGONF=$S('$G(PSGONF):ON_U_ON,1:+PSGONF_U_ON)
- I ($P(C,"^")'="Cz") I C="CA"!(C["B") W $S($P(ND4,"^",12):"D",1:" ") I C["B" S PSGONF=$S('$G(PSGONF):ON_U_ON,1:+PSGONF_U_ON)
- S SM=2-$S('$P(ND,"^",5):2,1:$P(ND,"^",6)),STS=$S($P(ND,U,28)]"":$P(ND,U,28),$P(ND,"^",9)]"":$P(ND,"^",9),1:"NF"),PF=$E("*",$P(ND,"^",20)>0),PSGID=$P(SCH,"^",2),SD=$P(SCH,"^",4) D
- .I ($P(C,"^")["C"&($P(C,"^")'["z"))!($P(C,"^",4)["C") S (PSGID,SD)="",PSGOD="********"
- I STS="A",($P(ND,U,27)="R") S STS="R"
- ;S WS=0,PSGOD=$$ENDTC^PSGMI(PSGID) ;#373
- S WS=0,PSGOD=$$ENDTC2^PSGMI(PSGID) ;#373 START DATE
- S:PSJPWD WS=$$WS^PSJO(PSJPWD,PSGP,F,+O)
- NEW MARX
- S PSJORFLG=""
- S:($P(C,"^")'="Cz") PSJORFLG=+O_$S(C["B":"P",C["C":"P",1:"U") S:($P(C,"^")="Cz") PSJORFLG=+O_$S($P(C,"^",4)["B":"P",$P(C,"^",4)["C":"P",1:"U")
- ;D DRGDISP^PSJLMUT1(PSGP,PSJORFLG,40,54,.MARX,0) ;#373
- D DRGDISP^PSJLMUT1(PSGP,PSJORFLG,34,28,.MARX,0) ;#373
- NEW X F X=0:0 S X=$O(MARX(X)) Q:'X W @($S(X=1:"?9",1:"!?11")) W MARX(X) D ;D:X=1 #373
- . ;N RNDT,O2 S O2=O S:+O2=O O2=O2_"P" S RNDT=$$LASTREN^PSJLMPRI(PSGP,O2) I RNDT]"" S RNDT=$E($$ENDTC^PSGMI(RNDT),1,5) ;#373
- . N O2 S RNDT="",O2=O S:+O2=O O2=O2_"P" S RNDT=$$LASTREN^PSJLMPRI(PSGP,O2) I RNDT]"" S RNDT=$E($$ENDTC2^PSGMI(RNDT),1,10) ;#373
- . ;I ($P(C,"^")'="Cz") W ?50,$S(C["C":"?",ST'="z":ST,1:"?"),?53,$E(PSGOD,1,5) ;#373
- . ;I ($P(C,"^")="Cz") W ?50,$S($P(C,"^",4)["C":"?",ST'="z":ST,1:"?"),?53,$E(PSGOD,1,5) ;#373
- . I ($P(C,"^")'="Cz") W:X=1 ?46,$S(C["C":"?",ST'="z":ST,1:"?"),?49,$E(PSGOD,1,10) ;#373
- . I ($P(C,"^")="Cz") W:X=1 ?46,$S($P(C,"^",4)["C":"?",ST'="z":ST,1:"?"),?49,$E(PSGOD,1,10) ;#373
- . ;S SD=$$ENDTC^PSGMI(SD) W ?60,$E(SD,1,5),?67,STS ;#373
- . S SD=$$ENDTC2^PSGMI(SD) W:X=1 ?60,$E(SD,1,10),?71,STS ;#373
- . ;I NF!WS!SM!PF!RNDT W ?71 W:NF "NF " W:WS "WS " W:RNDT RNDT_" " W:SM $E("HSM",SM,3) W:PF ?79,"*" ;#373
- . I NF!WS!SM!PF D:X=1 ;#373
- .. W ?74 W:NF "NF " W:WS "WS " W:SM $E("HSM",SM,3) W:PF ?79,"*" ;#373
- . I RNDT]"",X=2 W ?49,"Renewed: ",$E(RNDT,1,10) ;#373
- I '$D(MARX(2)),RNDT]"" W !?49,"Renewed: ",$E(RNDT,1,10) ; in case no line 2 of Med #373
- K RNDT ; #373
- I ND6]"" S Y=$$ENSET^PSGSICHK($P(ND6,"^")) W !?11 F X=1:1:$L(Y," ") S V=$P(Y," ",X) W:$L(V)+$X>66 !?11 W V_" "
- K PSJORFLG
- Q
- ;
- TF ;
- NEW SLS S SLS="",$P(SLS," -",40)=""
- I $P(C,"^")="Cz" Q:(TF2=$P(C,"^",2)) S TF2=$P(C,"^",2)
- S LN2=$S(($P(C,"^")="Cz"):$$TXT^PSJO(C),C="A":$$TXT^PSJO("A"),C["CC":$$TXT^PSJO("PR"),C["CD":$$TXT^PSJO("PC"),C["C":$$TXT^PSJO("P"),C["BD":$$TXT^PSJO("NC"),C["B":$$TXT^PSJO("N"),C="DF":$$TXT^PSJO("DF"),1:$$TXT^PSJO("NA"))
- W:$D(^TMP("PSG",$J,C)) !,$E($E(SLS,1,(80-$L(LN2))/2)_" "_LN2_$E(SLS,1,(80-$L(LN2))/2),1,80)
- I $P(C,"^")'="Cz" S F="^PS("_$S(C["C":"53.1,",C["B":"53.1,",1:"55,"_PSGP_",5,",1:"53.1,") S TF=$S(C["C":0,1:TF)
- I $P(C,"^")="Cz" N CCL S CCL=$P(C,"^",4) S F="^PS("_$S(CCL["C":"53.1,",CCL["B":"53.1,",1:"55,"_PSGP_",5,",1:"53.1,") S TF=$S(CCL["C":0,1:TF)
- Q
- ;
- GET ;
- S $P(LN2,"-",81)="",PG=$D(PSGVWA),(ON,PSGONC,PSGONR,PSGONV,SLS)="",$P(SLS," -",15)="",TF=1,RB=$S(PSJPRB]"":PSJPRB,1:"*NF*"),WD=$S(PSJPWDN]"":PSJPWDN,PSJPWD:PSJPWD_";DIC(42,",1:"*NF*")
- ;
- NP I ON,'CML W $C(7) R !," '^' TO QUIT ",NP:DTIME W:'$T $C(7) S:'$T NP="^" W:NP'["^" $C(13)," ",$C(13),# Q
- I ON,CML D BOT
- Q:$G(PSGOL)="N"
- ;
- S PG=PG+1
- S:'$D(PSJOPC) PSJOPC=1 S PSJTEAM=$S($D(PSJSEL("TM")):1,1:0)
- D ENTRY^PSJHEAD(PSGP,PSJOPC,PG,$G(PSJNARC),PSJTEAM)
- W:PG>1 !,$E(LN2,1,80) Q
- ;
- BOT ;
- F Q=$Y:1:IOSL-4 W !
- W !,?2,$P(PSGP(0),"^"),?40,PSJPPID,?70,$E($P(PSJPDOB,"^",2),1,8) Q
- ;
- ENHEAD ;
- K LN2,PSGPR,PSGPRP D NOW^%DTC S HDT=$$ENDTC^PSGMI(+$E(%,1,12)),PSGVWA=1,PSGOH="U N I T D O S E P R O F I L E" D GET
- D D1 K PSGONC,PSGONR,PSGONV,PSGVWA Q
- ;
- ENVBW ;
- S PSGOH=$S(PSGVBWTO=1:"N O N - V E R I F I E D O R D E R S",PSGVBWTO=2:"P E N D I N G O R D E R S",1:"N O N - V E R I F I E D / P E N D I N G O R D E R S")
- D EN Q
- ENPR ;
- S PSGOH="U N I T D O S E P R O F I L E" G GET
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGO 6982 printed Mar 13, 2025@21:06:38 Page 2
- PSGO ;BIR/CML3,MV - PRINTS PATIENT'S ORDERS ;Jul 12, 2018@13:10
- +1 ;;5.0;INPATIENT MEDICATIONS;**4,58,110,181,275,373**;16 DEC 97;Build 3
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA #2191.
- +4 ;
- +5 KILL ^TMP("PSJON",$JOB),PSGONF
- SET PSGOH="U N I T D O S E P R O F I L E"
- DO ENGORD^PSGOU
- +6 ;
- EN ;
- +1 NEW TF2
- SET TF2=""
- +2 SET CML=IO'=IO(0)!($EXTRACT(IOST,1,2)'="C-")
- SET NP=""
- NEW RB
- +3 USE IO
- DO GET
- IF '$DATA(^TMP("PSG",$JOB))
- WRITE !,SLS,SLS,$EXTRACT(SLS,1,24),!?22,"NO ORDERS FOUND"
- if "SL"[PSGOL
- WRITE " FOR A ",$SELECT(PSGOL="S":"SHORT",1:"LONG")," PROFILE."
- +4 if NP["^"
- GOTO DONE
- +5 IF '$TEST
- SET (C,DRG)=""
- SET LD=0
- +6 IF '$TEST
- DO DRG
- if NP["^"
- GOTO DONE
- +7 IF CML
- IF $SELECT('$DATA(PSGPRP):1,1:PSGPRP="P")
- DO BOT
- +8 ;
- DONE ;
- +1 IF $SELECT('$DATA(PSGPRP):1,1:PSGPRP="P")
- KILL ^TMP("PSG",$JOB)
- +2 SET PSGON=$SELECT('CML:ON,1:0)
- if '$DATA(PSGVBW)
- KILL PSGODT
- +3 ;
- D1 ;
- +1 KILL C,CML,DN,DO,DRG,F,GIVE,HDT,LN2,NF,ND,ND4,ND6,NP,O,ON,PF,PG,PSGHD,PSGOH,PSJTEAM,RCT,RF,RTE,S,SCH,SD,SLS,SM,ST,STS,TF,UDU,V,WD,WS,WT
- QUIT
- +2 ;
- DRG ;
- +1 IF PSGOL'="N"
- FOR
- SET C=$ORDER(^TMP("PSG",$JOB,C))
- if C=""!(NP["^")
- QUIT
- if $SELECT(($PIECE(C,"^")="Cz")&(TF2'=$PIECE(C,"^",2))
- DO TF
- FOR ST="C","O","OC","P","R","z"
- Begin DoDot:1
- +2 FOR
- SET DRG=$ORDER(^TMP("PSG",$JOB,C,ST,DRG))
- if DRG=""!(NP["^")
- QUIT
- SET NF=^(DRG)
- SET O=$PIECE(DRG,"^",2)
- SET DN=$PIECE(DRG,"^")
- if $Y+4>IOSL
- DO NP
- if NP["^"
- QUIT
- DO P
- End DoDot:1
- +3 IF PSGOL="N"
- FOR
- SET LD=$ORDER(^TMP("PSG",$JOB,LD))
- if 'LD
- QUIT
- SET X=^(LD)
- SET NF=$PIECE(X,U)
- SET C=$PIECE(X,U,2)
- SET ST=$PIECE(X,U,3)
- SET DN=$PIECE(X,U,4)
- SET O=$PIECE(LD,U,2)
- DO P
- +4 QUIT
- +5 ;
- P ;Display drug data stored in ^TMP("PSG",$J
- +1 IF $GET(O)["U"&($PIECE(C,"^",4)="A")
- NEW F
- SET F="^PS(55,PSGP,5,"
- +2 SET ON=ON+1
- IF 'CML
- Begin DoDot:1
- +3 NEW PSJOSUFX
- IF ($PIECE(C,"^")="Cz")
- SET PSJOSUFX=$SELECT(($PIECE(C,"^",4))["CD":"",($PIECE(C,"^",4)["C"):"P",($PIECE(C,"^",4)["BD"):"",($PIECE(C,"^",4)["B"):"P",1:"U")
- +4 IF ($PIECE(C,"^")'="Cz")
- SET PSJOSUFX=$SELECT(C["CD":"",C["C":"P",C["BD":"",C["B":"P",1:"U")
- +5 SET ^TMP("PSJON",$JOB,ON)=+O_PSJOSUFX
- +6 if (C'["O"&($PIECE(C,"^")'="Cz"))
- SET PSGONC=ON
- if ($PIECE(C,"^")="Cz"&($PIECE(C,"^",4)'["O"))
- SET PSGONC=ON
- End DoDot:1
- +7 if PSGOL="N"
- QUIT
- +8 WRITE !,$JUSTIFY(ON,4),?5
- +9 IF (C["CD"&($PIECE(C,"^")'="Cz"))!($PIECE(C,"^",4)["CD")
- NEW PSJO,OO
- SET PSJO=O
- SET OO=0
- FOR
- SET OO=$ORDER(^PS(53.1,"ACX",PSJO,OO))
- if 'OO
- QUIT
- SET O=OO
- DO P2
- WRITE !
- +10 IF (C["BD"&($PIECE(C,"^")'="Cz"))!($PIECE(C,"^",4)["BD")
- NEW PSJO,OO
- SET PSJO=O
- SET OO=0
- FOR
- SET OO=$ORDER(^PS(53.1,"ACX",PSJO,OO))
- if 'OO
- QUIT
- SET O=OO
- DO P2
- WRITE !
- +11 if (C["BD"&($PIECE(C,"^")'="Cz"))
- QUIT
- if (C["CD"&($PIECE(C,"^")'="Cz"))
- QUIT
- if ($PIECE(C,"^",4)["BD")
- QUIT
- if ($PIECE(C,"^",4)["CD")
- QUIT
- +12 ; naked references below refer to full reference inside indirection @(F_+O_".0)" for either file 53.1 or 55
- P2 SET ND=$GET(@(F_+O_",0)"))
- SET SCH=$GET(^(2))
- SET ND4=$GET(^(4))
- SET ND6=$GET(^(6))
- SET DO=$GET(^(.2))
- +1 IF (C="A"!($PIECE(C,"^",4)="A"))
- IF PSJSYSU
- IF '$PIECE(ND4,"^",+PSJSYSU)
- IF $PIECE(ND4,"^",+PSJSYSU=1+9)
- SET PSGONV=ON
- +2 IF (C="A"!(C="O"))!(($PIECE(C,"^",4)="A")!($PIECE(C,"^",4)="O"))
- if $PIECE(ND,"^",9)'="H"&'CML
- SET PSGONR=ON
- Begin DoDot:1
- +3 SET V='$PIECE(ND4,"^",UDU)
- SET V=$SELECT(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)
- +4 WRITE $SELECT(ND4="":" ",$PIECE(ND4,"^",12):"D",V!$PIECE(ND4,"^",19)&$PIECE(ND4,"^",18):"H",V!$PIECE(ND4,"^",23)&$PIECE(ND4,"^",22):"H",V!$PIECE(ND4,"^",16)&$PIECE(ND4,"^",15):"R",1:" ")
- +5 WRITE $SELECT($PIECE(DO,U,4)="D":"d",1:" ")_$SELECT(V:"->",1:" ")
- End DoDot:1
- +6 IF ($PIECE(C,"^")="Cz")&(($PIECE(C,"^",4)="CA")!($PIECE(C,"^",4)["B"))
- WRITE $SELECT($PIECE(ND4,"^",12):"D",1:" ")
- IF ($PIECE(C,"^",4)["B")
- SET PSGONF=$SELECT('$GET(PSGONF):ON_U_ON,1:+PSGONF_U_ON)
- +7 IF ($PIECE(C,"^")'="Cz")
- IF C="CA"!(C["B")
- WRITE $SELECT($PIECE(ND4,"^",12):"D",1:" ")
- IF C["B"
- SET PSGONF=$SELECT('$GET(PSGONF):ON_U_ON,1:+PSGONF_U_ON)
- +8 SET SM=2-$SELECT('$PIECE(ND,"^",5):2,1:$PIECE(ND,"^",6))
- SET STS=$SELECT($PIECE(ND,U,28)]"":$PIECE(ND,U,28),$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)
- Begin DoDot:1
- +9 IF ($PIECE(C,"^")["C"&($PIECE(C,"^")'["z"))!($PIECE(C,"^",4)["C")
- SET (PSGID,SD)=""
- SET PSGOD="********"
- End DoDot:1
- +10 IF STS="A"
- IF ($PIECE(ND,U,27)="R")
- SET STS="R"
- +11 ;S WS=0,PSGOD=$$ENDTC^PSGMI(PSGID) ;#373
- +12 ;#373 START DATE
- SET WS=0
- SET PSGOD=$$ENDTC2^PSGMI(PSGID)
- +13 if PSJPWD
- SET WS=$$WS^PSJO(PSJPWD,PSGP,F,+O)
- +14 NEW MARX
- +15 SET PSJORFLG=""
- +16 if ($PIECE(C,"^")'="Cz")
- SET PSJORFLG=+O_$SELECT(C["B":"P",C["C":"P",1:"U")
- if ($PIECE(C,"^")="Cz")
- SET PSJORFLG=+O_$SELECT($PIECE(C,"^",4)["B":"P",$PIECE(C,"^",4)["C":"P",1:"U")
- +17 ;D DRGDISP^PSJLMUT1(PSGP,PSJORFLG,40,54,.MARX,0) ;#373
- +18 ;#373
- DO DRGDISP^PSJLMUT1(PSGP,PSJORFLG,34,28,.MARX,0)
- +19 ;D:X=1 #373
- NEW X
- FOR X=0:0
- SET X=$ORDER(MARX(X))
- if 'X
- QUIT
- WRITE @($SELECT(X=1:"?9",1:"!?11"))
- WRITE MARX(X)
- Begin DoDot:1
- +20 ;N RNDT,O2 S O2=O S:+O2=O O2=O2_"P" S RNDT=$$LASTREN^PSJLMPRI(PSGP,O2) I RNDT]"" S RNDT=$E($$ENDTC^PSGMI(RNDT),1,5) ;#373
- +21 ;#373
- NEW O2
- SET RNDT=""
- SET O2=O
- if +O2=O
- SET O2=O2_"P"
- SET RNDT=$$LASTREN^PSJLMPRI(PSGP,O2)
- IF RNDT]""
- SET RNDT=$EXTRACT($$ENDTC2^PSGMI(RNDT),1,10)
- +22 ;I ($P(C,"^")'="Cz") W ?50,$S(C["C":"?",ST'="z":ST,1:"?"),?53,$E(PSGOD,1,5) ;#373
- +23 ;I ($P(C,"^")="Cz") W ?50,$S($P(C,"^",4)["C":"?",ST'="z":ST,1:"?"),?53,$E(PSGOD,1,5) ;#373
- +24 ;#373
- IF ($PIECE(C,"^")'="Cz")
- if X=1
- WRITE ?46,$SELECT(C["C":"?",ST'="z":ST,1:"?"),?49,$EXTRACT(PSGOD,1,10)
- +25 ;#373
- IF ($PIECE(C,"^")="Cz")
- if X=1
- WRITE ?46,$SELECT($PIECE(C,"^",4)["C":"?",ST'="z":ST,1:"?"),?49,$EXTRACT(PSGOD,1,10)
- +26 ;S SD=$$ENDTC^PSGMI(SD) W ?60,$E(SD,1,5),?67,STS ;#373
- +27 ;#373
- SET SD=$$ENDTC2^PSGMI(SD)
- if X=1
- WRITE ?60,$EXTRACT(SD,1,10),?71,STS
- +28 ;I NF!WS!SM!PF!RNDT W ?71 W:NF "NF " W:WS "WS " W:RNDT RNDT_" " W:SM $E("HSM",SM,3) W:PF ?79,"*" ;#373
- +29 ;#373
- IF NF!WS!SM!PF
- if X=1
- Begin DoDot:2
- +30 ;#373
- WRITE ?74
- if NF
- WRITE "NF "
- if WS
- WRITE "WS "
- if SM
- WRITE $EXTRACT("HSM",SM,3)
- if PF
- WRITE ?79,"*"
- End DoDot:2
- +31 ;#373
- IF RNDT]""
- IF X=2
- WRITE ?49,"Renewed: ",$EXTRACT(RNDT,1,10)
- End DoDot:1
- +32 ; in case no line 2 of Med #373
- IF '$DATA(MARX(2))
- IF RNDT]""
- WRITE !?49,"Renewed: ",$EXTRACT(RNDT,1,10)
- +33 ; #373
- KILL RNDT
- +34 IF ND6]""
- SET Y=$$ENSET^PSGSICHK($PIECE(ND6,"^"))
- WRITE !?11
- FOR X=1:1:$LENGTH(Y," ")
- SET V=$PIECE(Y," ",X)
- if $LENGTH(V)+$X>66
- WRITE !?11
- WRITE V_" "
- +35 KILL PSJORFLG
- +36 QUIT
- +37 ;
- TF ;
- +1 NEW SLS
- SET SLS=""
- SET $PIECE(SLS," -",40)=""
- +2 IF $PIECE(C,"^")="Cz"
- if (TF2=$PIECE(C,"^",2))
- QUIT
- SET TF2=$PIECE(C,"^",2)
- +3 SET LN2=$SELECT(($PIECE(C,"^")="Cz"):$$TXT^PSJO(C),C="A":$$TXT^PSJO("A"),C["CC":$$TXT^PSJO("PR"),C["CD":$$TXT^PSJO("PC"),C["C":$$TXT^PSJO("P"),C["BD":$$TXT^PSJO("NC"),C["B":$$TXT^PSJO("N"),C="DF":$$TXT^PSJO("DF"),1:$$TXT^PSJO("NA"))
- +4 if $DATA(^TMP("PSG",$JOB,C))
- WRITE !,$EXTRACT($EXTRACT(SLS,1,(80-$LENGTH(LN2))/2)_" "_LN2_$EXTRACT(SLS,1,(80-$LENGTH(LN2))/2),1,80)
- +5 IF $PIECE(C,"^")'="Cz"
- SET F="^PS("_$SELECT(C["C":"53.1,",C["B":"53.1,",1:"55,"_PSGP_",5,",1:"53.1,")
- SET TF=$SELECT(C["C":0,1:TF)
- +6 IF $PIECE(C,"^")="Cz"
- NEW CCL
- SET CCL=$PIECE(C,"^",4)
- SET F="^PS("_$SELECT(CCL["C":"53.1,",CCL["B":"53.1,",1:"55,"_PSGP_",5,",1:"53.1,")
- SET TF=$SELECT(CCL["C":0,1:TF)
- +7 QUIT
- +8 ;
- GET ;
- +1 SET $PIECE(LN2,"-",81)=""
- SET PG=$DATA(PSGVWA)
- SET (ON,PSGONC,PSGONR,PSGONV,SLS)=""
- SET $PIECE(SLS," -",15)=""
- SET TF=1
- SET RB=$SELECT(PSJPRB]"":PSJPRB,1:"*NF*")
- SET WD=$SELECT(PSJPWDN]"":PSJPWDN,PSJPWD:PSJPWD_";DIC(42,",1:"*NF*")
- +2 ;
- NP IF ON
- IF 'CML
- WRITE $CHAR(7)
- READ !," '^' TO QUIT ",NP:DTIME
- if '$TEST
- WRITE $CHAR(7)
- if '$TEST
- SET NP="^"
- if NP'["^"
- WRITE $CHAR(13)," ",$CHAR(13),#
- QUIT
- +1 IF ON
- IF CML
- DO BOT
- +2 if $GET(PSGOL)="N"
- QUIT
- +3 ;
- +1 SET PG=PG+1
- +2 if '$DATA(PSJOPC)
- SET PSJOPC=1
- SET PSJTEAM=$SELECT($DATA(PSJSEL("TM")):1,1:0)
- +3 DO ENTRY^PSJHEAD(PSGP,PSJOPC,PG,$GET(PSJNARC),PSJTEAM)
- +4 if PG>1
- WRITE !,$EXTRACT(LN2,1,80)
- QUIT
- +5 ;
- BOT ;
- +1 FOR Q=$Y:1:IOSL-4
- WRITE !
- +2 WRITE !,?2,$PIECE(PSGP(0),"^"),?40,PSJPPID,?70,$EXTRACT($PIECE(PSJPDOB,"^",2),1,8)
- QUIT
- +3 ;
- ENHEAD ;
- +1 KILL LN2,PSGPR,PSGPRP
- DO NOW^%DTC
- SET HDT=$$ENDTC^PSGMI(+$EXTRACT(%,1,12))
- SET PSGVWA=1
- SET PSGOH="U N I T D O S E P R O F I L E"
- DO GET
- +2 DO D1
- KILL PSGONC,PSGONR,PSGONV,PSGVWA
- QUIT
- +3 ;
- ENVBW ;
- +1 SET PSGOH=$SELECT(PSGVBWTO=1:"N O N - V E R I F I E D O R D E R S",PSGVBWTO=2:"P E N D I N G O R D E R S",1:"N O N - V E R I F I E D / P E N D I N G O R D E R S")
- +2 DO EN
- QUIT
- ENPR ;
- +1 SET PSGOH="U N I T D O S E P R O F I L E"
- GOTO GET
- +2 QUIT
