- PSJO1 ;BIR/CML3,PR - GET UNIT DOSE/IV ORDERS FOR INPATIENT ;15 May 98 / 9:28 AM
- ;;5.0;INPATIENT MEDICATIONS;**3,47,56,58,109,110,127,162,181,275,292,299,312,316**;16 DEC 97;Build 8
- ;
- ; Reference to ^PS(55 is supported by DBIA# 2191.
- ; Reference to ^%DTC is supported by DBIA# 10000.
- ; Reference to ^%ZOSV is supported by DBIA# 10097.
- ; Reference to XLFDT is supported by DBIA# 10103.
- ;
- ECHK ;
- S C="A",ON=+O_"U",START=$G(^PS(55,PSGP,5,+O,2)),STOP=$P(START,U,4),START=$P(START,U,2) S:PSJOS START=-START
- I +START>PSGDT,(STOP>PSGDT) G SET
- S ND=$G(^PS(55,PSGP,5,+O,0)) G:$S($P(ND,"^",9)="":1,1:"DE"'[$P(ND,"^",9)) SET S ND4=$G(^PS(55,PSGP,5,+O,4)) I ST'="O",SD'<PSGODT,$S($P(ND,"^",9)="E":$P(ND4,"^",16),1:0)
- E I ST="O",$P(ND,"^",9)="E",$S('$P(ND4,"^",UDU):1,SD<PSGODT:0,1:$P(ND4,"^",16))
- E I PSJOL="S",(STOP>$P($G(PSJDCEXP),U,2)) S C="DF" G SET
- E Q:PSJOL="S" S C="O"
- ;
- SET ;
- I ON["P",($D(PRNTON)!($D(P("PRNTON")))) N PSJOK S PSJOK=$$COMCHK($S($G(P("PRNTON"))]"":P("PRNTON"),$G(PRNTON)]"":PRNTON,1:""),PSJPTYP) Q:'PSJOK
- NEW DRUGNAME,CLINFLAG D DRGDISP^PSJLMUT1(PSGP,ON,40,0,.DRUGNAME,1)
- S DN=DRUGNAME(1),SUB=$S(PSJOS:START,1:$E(DN,1,40))
- I ON["P",$G(P("PRNTON"))]"",$G(PRNTON)=+P("PRNTON") Q
- I ON["P",$G(P("PRNTON"))]"" S PRNTON=+P("PRNTON"),ON=+P("PRNTON")
- S CLINFLAG=$$CLINIC(PSGP,ON) I CLINFLAG]"" D
- .N CLINSORT,SORT S CLINSORT=$$CLINSORT(C)
- .S C="Cz^"_CLINFLAG_"^"_CLINSORT_"^"_C
- S ^TMP("PSJ",$J,C,$S(PSJOS:SUB,1:ST),$S(PSJOS:ST,1:SUB),ON)=DN_"^"_$G(NF),PSJOCNT=PSJOCNT+1 Q
- ;
- IVSET ;Set IV data in ^TMP("PSJ",$J,.
- N DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,NAME,ND
- I ON["V" S ON55=ON,Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,9,17 S P(X)=$P(Y,U,X)
- I ON["V",(P(2)=""),(P(3)="") Q
- I ON'["V" S ND=$G(^PS(53.1,+ON,0)) I 'ND K ^PS(53.1,"AS",SD,PSGP,+ON) Q
- I ON'["V",ND S P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^PS(53.1,+ON,2)),P(9)=$P(Y,U),P(2)=$P(Y,U,2),P(3)=$P(Y,U,4),P(4)=$P($G(^PS(53.1,+ON,8)),U),P("PRNTON")=$P($G(^PS(53.1,+ON,.2)),U,8)
- I ON'["V",P("PRNTON")]"" N PSJOK S PSJOK=$$COMCHK(P("PRNTON"),PSJPTYP) Q:'PSJOK
- D @$S(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA"),GTOT^PSIVUTL(P(4))
- I $G(DRG) S DRGT=$S($G(DRG("AD",1))]"":$P($G(DRG("AD",1)),U,2),1:$P($G(DRG("SOL",1)),U,2)),ORTX=DRGT
- I $G(ORTX)="",(ON'["V") D DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1) S ORTX=NAME(1)
- ;* I $G(ORTX)=""!(ON'["V") D DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1) S ORTX=NAME(1)
- S:$G(ORTX)="" ORTX="NOT FOUND"
- ;
- IVSET1 ;
- ;* S TYP=$S(P(2)=P(3):"O",1:"C"),STAT=$S("ED"[P(17):"O",P(17)="P":"P",1:"A")
- N PSJCLIN,CLINSORT
- S TYP=$$ONE^PSJBCMA(PSGP,ON,P(9),P(2),P(3)) I TYP'="O" S TYP=$S(ON["P":"z",1:"C")
- S STAT=$S($G(PSJPRI)="D":"A","ED"[P(17):"O",P(17)="P":"P",1:"A")
- I P(17)="P" S STAT="C"_$S($P($G(^PS(53.1,+ON,.2)),U,8)]"":"D",$P($G(^PS(53.1,+ON,.2)),U,4)="S":"A",$P($G(^(0)),U,24)="R":"C",1:"B")
- I PSJOL="S",(STAT="O"),(P(3)>$P($G(PSJDCEXP),U,2)) S STAT="DF"
- I ON["P",$G(P("PRNTON"))]"",PRNTON=+P("PRNTON") Q
- I ON["P",$G(P("PRNTON"))]"" S PRNTON=+P("PRNTON"),ON=+P("PRNTON")
- S PSJCLIN=$$CLINIC(PSGP,ON) I PSJCLIN]"" D
- .N STAT2 S STAT2=$S($P(STAT,"^",4)]"":$P(STAT,"^",4),1:STAT)
- .N CLINSORT S CLINSORT=$$CLINSORT(STAT) S STAT="Cz^"_PSJCLIN_"^"_CLINSORT_"^"_STAT2
- S ^TMP("PSJ",$J,STAT,$S(PSJOS:-P(2),1:TYP),$S(PSJOS:TYP,1:ORTX),ON)="^F",PSJOCNT=PSJOCNT+1
- Q
- ;
- ENU ; update status field to reflect expired orders, if necessary
- W !!,"...a few moments, I have some updating to do..."
- ENUNM ;
- F PSJOQ=+PSJPAD:0 S PSJOQ=$O(^PS(55,PSGP,5,"AUS",PSJOQ)) Q:'PSJOQ!(PSJOQ>PSGDT) S UPD=PSJOQ D
- .F PSJOQQ=0:0 S PSJOQQ=$O(^PS(55,PSGP,5,"AUS",PSJOQ,PSJOQQ)) Q:'PSJOQQ I $D(^PS(55,PSGP,5,PSJOQQ,0)),"DEH"'[$E($P(^(0),"^",9)) D
- ..N DIE,DA,DR,X,Y,QQON S QQON=PSJOQQ,DIE="^PS(55,"_PSGP_",5,",DA(1)=PSGP,DA=+QQON,DR="28////E" D ^DIE
- ..S ORIFN=$P(^PS(55,PSGP,5,+QQON,0),"^",21) D EN1^PSJHL2(PSGP,"SC",QQON_"U")
- K UPD,PSJOQ,PSJOQQ Q
- ;
- EN(PSJPTYP) ; enter here
- ; PSJPTYP=1:UD ONLY, 2:IV ONLY, 3:BOTH
- N PSJX,PSJY
- S PSJDCEXP=$$RECDCEXP^PSJP()
- S PSJOL=$G(PSJOL) ; Initialize if no 'View Profile' option selected
- I PSJOL="L",$D(XRTL) D T0^%ZOSV
- K ^TMP("PSJ",$J) D NOW^%DTC S PSGDT=+$E(%,1,12),DT=$$DT^XLFDT,PSJOS=$P(PSJSYSP0,"^",11),UDU=$S($P(PSJSYSU,";",3)>1:3,1:1)
- S PSJOCNT=0 I PSJPTYP>1 F PSJORD=0:0 S PSJORD=$O(^PS(55,DFN,"IV",PSJORD)) Q:'PSJORD D
- .S PSJX=$G(^PS(55,DFN,"IV",+PSJORD,0))
- .S PSJY=$P(PSJX,U,17)
- .I $P(PSJX,U,3)<PSGDT,"AR"[PSJY S $P(^PS(55,DFN,"IV",+PSJORD,0),U,17)="E",PSJY="E",ON=+PSJORD D EXPIR^PSIVOE
- .I +PSJSYSU=3,('+$P($G(^PS(55,DFN,"IV",+PSJORD,4)),U,4)),($P($G(^(.2)),U,4)="D") S PSJPRI="D"
- .I $S($G(PSJPRI)="D":1,PSJY="P":0,PSJOL="L":1,$P(PSJX,U,3)>$P($G(PSJDCEXP),U,2):1,1:"DPE"'[PSJY) S ON=+PSJORD_"V" D IVSET K PSJPRI,ON
- D NOW^%DTC S PSJIVOF=PSJOCNT,PSGDT=%,(X1,DT)=$P(%,"."),X2=-2 D C^%DTC S PSGODT=X_(PSGDT#1),HDT=$$ENDTC^PSGMI(PSGDT)
- D ENUNM
- I PSJPTYP'=2 F ST="C","O","OC","P","R" F SD=0:0 S SD=$O(^PS(55,PSGP,5,"AU",ST,SD)) Q:'SD F O=0:0 S O=$O(^PS(55,PSGP,5,"AU",ST,SD,O)) Q:'O D ECHK
- Q:$D(PSGONNV)
- ;I PSJPTYP'=2 F SD="I","N" S O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=+O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D NVSET
- N PRNTON F SD="I","N" S (PRNTON,O)=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=+O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D NVSET
- ;I $S(+PSJSYSU=3:1,1:$D(PSGLPF)) S O=0,SD="P" F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D @$S("FI"[X:"IVSET",1:"NVSET")
- N PRNTON S (PRNTON,O)=0,SD="P" F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D @$S("FI"[X:"IVSET",1:"NVSET")
- I PSJOL="L",$D(XRT0) S XRTN="PSJO1" D T1^%ZOSV
- D CLEAN^PSJIMO1(PSGP)
- Q
- ;
- NVSET ; Set up orders from 53.1.
- N ND S ND=$G(^PS(53.1,O,0)) I 'ND D Q
- .K ^PS(53.1,"AS",SD,PSGP,O)
- I $P(ND,U,15),$G(PSGP) I PSGP'=$P(ND,U,15) D Q
- .K ^PS(53.1,"AS",SD,PSGP,O)
- I $P(ND,U,9)["D" D Q
- .K ^PS(53.1,"AS",SD,PSGP,O)
- .N ND2 S ND2=$G(^PS(53.1,O,.2)) I $P(ND2,U,8) K ^PS(53.1,"ACX",$P(ND2,U,8))
- S ST=$P($G(^PS(53.1,O,0)),U,7),START=-$P($G(^(2)),U,2),P("PRNTON")=$P($G(^PS(53.1,O,.2)),"^",8) S:ST="" ST="z"
- S C=$S(((SD="N")&($P($G(^PS(53.1,O,.2)),U,8)]"")):"BD",SD="N":"BA",SD="I":"BB",$P($G(^PS(53.1,O,.2)),U,8)]"":"CD",$P($G(^PS(53.1,O,.2)),U,4)="S":"CA",$P($G(^(0)),U,24)="R":"CC",1:"CB")
- ;I C="CC" S C=$$CKPC^PSGOU(PSGP,+$P($G(^PS(53.1,O,0)),U,25),O)
- D SET
- Q
- ;
- KILL ;
- K P,STAT,TYP,ORTX,N,JJ
- Q
- COMCHK(PSJCOM,PSJPTYP) ;Check complex orders for order type
- S OK=0
- I PSJCOM=0 S OK=1 Q OK
- I PSJCOM="" Q OK
- I PSJPTYP="" Q OK
- I '$D(^PS(53.1,"ACX",PSJCOM)) Q OK
- S OK=1 I PSJPTYP=3 Q OK
- N PSJON S PSJON=""
- F S PSJON=$O(^PS(53.1,"ACX",PSJCOM,PSJON)) Q:'PSJON D Q:OK=0
- .I $P($G(^PS(53.1,PSJON,0)),"^",9)["D" K ^PS(53.1,"ACX",PSJCOM)
- .I $P($G(^PS(53.1,PSJON,0)),"^",4)'="U",PSJPTYP=1 S OK=0 Q
- .I $P($G(^PS(53.1,PSJON,0)),"^",4)="U",PSJPTYP=2 S OK=0 Q
- Q OK
- ;
- CLINIC(PSGP,ORDER) ; Return Clinic Name for a given patient/order combination
- I '$G(ORDER) Q ""
- N CLN S CLN=$S(ORDER["P":$G(^PS(53.1,+ORDER,"DSS")),ORDER["V":$G(^PS(55,PSGP,"IV",+ORDER,"DSS")),ORDER["U":$G(^PS(55,PSGP,5,+ORDER,8)),1:"")
- I 'CLN,(ORDER=+ORDER) D
- .I $D(^PS(53.1,"ACX",+ORDER)) N PSJORD S PSJORD=0 F S PSJORD=$O(^PS(53.1,"ACX",+ORDER,PSJORD)) Q:'PSJORD!$G(CLN) S CLN=$G(^PS(53.1,+PSJORD,"DSS"))
- .I $D(^PS(55,"ACX",+ORDER)) N ACX2,PSJORD S ACX2="" F S ACX2=$O(^PS(55,"ACX",+ORDER,ACX2)) Q:'ACX2!$G(CLN) S PSJORD=0 F S PSJORD=$O(^PS(55,"ACX",+ORDER,ACX2,PSJORD)) Q:'PSJORD!$G(CLN) D
- ..S CLN=$S(PSJORD["P":$G(^PS(53.1,+PSJORD,"DSS")),PSJORD["V":$G(^PS(55,PSGP,"IV",+PSJORD,"DSS")),ORDER["U":$G(^PS(55,PSGP,5,+PSJORD,8)),1:"")
- S CLN=$S($P(CLN,"^",2):$$GET1^DIQ(44,+CLN,.01),1:"")
- Q CLN
- ;
- CLINSORT(C) ; Return integer sort value based on order status
- I $P(C,"^")="Cz" N CTMP S CTMP=C N C S C=$P(CTMP,"^",4)
- S SORT=$S($E(C)="A":3,$E(C)["C"!($E(C)["P"):1,($E(C)["B"):2,($E(C)["DF"):4,1:5)
- Q SORT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJO1 8112 printed Feb 18, 2025@23:34:18 Page 2
- PSJO1 ;BIR/CML3,PR - GET UNIT DOSE/IV ORDERS FOR INPATIENT ;15 May 98 / 9:28 AM
- +1 ;;5.0;INPATIENT MEDICATIONS;**3,47,56,58,109,110,127,162,181,275,292,299,312,316**;16 DEC 97;Build 8
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +4 ; Reference to ^%DTC is supported by DBIA# 10000.
- +5 ; Reference to ^%ZOSV is supported by DBIA# 10097.
- +6 ; Reference to XLFDT is supported by DBIA# 10103.
- +7 ;
- ECHK ;
- +1 SET C="A"
- SET ON=+O_"U"
- SET START=$GET(^PS(55,PSGP,5,+O,2))
- SET STOP=$PIECE(START,U,4)
- SET START=$PIECE(START,U,2)
- if PSJOS
- SET START=-START
- +2 IF +START>PSGDT
- IF (STOP>PSGDT)
- GOTO SET
- +3 SET ND=$GET(^PS(55,PSGP,5,+O,0))
- if $SELECT($PIECE(ND,"^",9)=""
- GOTO SET
- SET ND4=$GET(^PS(55,PSGP,5,+O,4))
- IF ST'="O"
- IF SD'<PSGODT
- IF $SELECT($PIECE(ND,"^",9)="E":$PIECE(ND4,"^",16),1:0)
- +4 IF '$TEST
- IF ST="O"
- IF $PIECE(ND,"^",9)="E"
- IF $SELECT('$PIECE(ND4,"^",UDU):1,SD<PSGODT:0,1:$PIECE(ND4,"^",16))
- +5 IF '$TEST
- IF PSJOL="S"
- IF (STOP>$PIECE($GET(PSJDCEXP),U,2))
- SET C="DF"
- GOTO SET
- +6 IF '$TEST
- if PSJOL="S"
- QUIT
- SET C="O"
- +7 ;
- SET ;
- +1 IF ON["P"
- IF ($DATA(PRNTON)!($DATA(P("PRNTON"))))
- NEW PSJOK
- SET PSJOK=$$COMCHK($SELECT($GET(P("PRNTON"))]"":P("PRNTON"),$GET(PRNTON)]"":PRNTON,1:""),PSJPTYP)
- if 'PSJOK
- QUIT
- +2 NEW DRUGNAME,CLINFLAG
- DO DRGDISP^PSJLMUT1(PSGP,ON,40,0,.DRUGNAME,1)
- +3 SET DN=DRUGNAME(1)
- SET SUB=$SELECT(PSJOS:START,1:$EXTRACT(DN,1,40))
- +4 IF ON["P"
- IF $GET(P("PRNTON"))]""
- IF $GET(PRNTON)=+P("PRNTON")
- QUIT
- +5 IF ON["P"
- IF $GET(P("PRNTON"))]""
- SET PRNTON=+P("PRNTON")
- SET ON=+P("PRNTON")
- +6 SET CLINFLAG=$$CLINIC(PSGP,ON)
- IF CLINFLAG]""
- Begin DoDot:1
- +7 NEW CLINSORT,SORT
- SET CLINSORT=$$CLINSORT(C)
- +8 SET C="Cz^"_CLINFLAG_"^"_CLINSORT_"^"_C
- End DoDot:1
- +9 SET ^TMP("PSJ",$JOB,C,$SELECT(PSJOS:SUB,1:ST),$SELECT(PSJOS:ST,1:SUB),ON)=DN_"^"_$GET(NF)
- SET PSJOCNT=PSJOCNT+1
- QUIT
- +10 ;
- IVSET ;Set IV data in ^TMP("PSJ",$J,.
- +1 NEW DRG,DRGT,ON55,ORTX,P,STAT,TYP,X,Y,NAME,ND
- +2 IF ON["V"
- SET ON55=ON
- SET Y=$GET(^PS(55,DFN,"IV",+ON,0))
- FOR X=2,3,4,9,17
- SET P(X)=$PIECE(Y,U,X)
- +3 IF ON["V"
- IF (P(2)="")
- IF (P(3)="")
- QUIT
- +4 IF ON'["V"
- SET ND=$GET(^PS(53.1,+ON,0))
- IF 'ND
- KILL ^PS(53.1,"AS",SD,PSGP,+ON)
- QUIT
- +5 IF ON'["V"
- IF ND
- SET P(17)=$PIECE($GET(^PS(53.1,+ON,0)),U,9)
- SET Y=$GET(^PS(53.1,+ON,2))
- SET P(9)=$PIECE(Y,U)
- SET P(2)=$PIECE(Y,U,2)
- SET P(3)=$PIECE(Y,U,4)
- SET P(4)=$PIECE($GET(^PS(53.1,+ON,8)),U)
- SET P("PRNTON")=$PIECE($GET(^PS(53.1,+ON,.2)),U,8)
- +6 IF ON'["V"
- IF P("PRNTON")]""
- NEW PSJOK
- SET PSJOK=$$COMCHK(P("PRNTON"),PSJPTYP)
- if 'PSJOK
- QUIT
- +7 DO @$SELECT(ON["V":"GTDRG^PSIVORFB",1:"GTDRG^PSIVORFA")
- DO GTOT^PSIVUTL(P(4))
- +8 IF $GET(DRG)
- SET DRGT=$SELECT($GET(DRG("AD",1))]"":$PIECE($GET(DRG("AD",1)),U,2),1:$PIECE($GET(DRG("SOL",1)),U,2))
- SET ORTX=DRGT
- +9 IF $GET(ORTX)=""
- IF (ON'["V")
- DO DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1)
- SET ORTX=NAME(1)
- +10 ;* I $G(ORTX)=""!(ON'["V") D DRGDISP^PSJLMUT1(PSGP,+ON_"P",40,"",.NAME,1) S ORTX=NAME(1)
- +11 if $GET(ORTX)=""
- SET ORTX="NOT FOUND"
- +12 ;
- IVSET1 ;
- +1 ;* S TYP=$S(P(2)=P(3):"O",1:"C"),STAT=$S("ED"[P(17):"O",P(17)="P":"P",1:"A")
- +2 NEW PSJCLIN,CLINSORT
- +3 SET TYP=$$ONE^PSJBCMA(PSGP,ON,P(9),P(2),P(3))
- IF TYP'="O"
- SET TYP=$SELECT(ON["P":"z",1:"C")
- +4 SET STAT=$SELECT($GET(PSJPRI)="D":"A","ED"[P(17):"O",P(17)="P":"P",1:"A")
- +5 IF P(17)="P"
- SET STAT="C"_$SELECT($PIECE($GET(^PS(53.1,+ON,.2)),U,8)]"":"D",$PIECE($GET(^PS(53.1,+ON,.2)),U,4)="S":"A",$PIECE($GET(^(0)),U,24)="R":"C",1:"B")
- +6 IF PSJOL="S"
- IF (STAT="O")
- IF (P(3)>$PIECE($GET(PSJDCEXP),U,2))
- SET STAT="DF"
- +7 IF ON["P"
- IF $GET(P("PRNTON"))]""
- IF PRNTON=+P("PRNTON")
- QUIT
- +8 IF ON["P"
- IF $GET(P("PRNTON"))]""
- SET PRNTON=+P("PRNTON")
- SET ON=+P("PRNTON")
- +9 SET PSJCLIN=$$CLINIC(PSGP,ON)
- IF PSJCLIN]""
- Begin DoDot:1
- +10 NEW STAT2
- SET STAT2=$SELECT($PIECE(STAT,"^",4)]"":$PIECE(STAT,"^",4),1:STAT)
- +11 NEW CLINSORT
- SET CLINSORT=$$CLINSORT(STAT)
- SET STAT="Cz^"_PSJCLIN_"^"_CLINSORT_"^"_STAT2
- End DoDot:1
- +12 SET ^TMP("PSJ",$JOB,STAT,$SELECT(PSJOS:-P(2),1:TYP),$SELECT(PSJOS:TYP,1:ORTX),ON)="^F"
- SET PSJOCNT=PSJOCNT+1
- +13 QUIT
- +14 ;
- ENU ; update status field to reflect expired orders, if necessary
- +1 WRITE !!,"...a few moments, I have some updating to do..."
- ENUNM ;
- +1 FOR PSJOQ=+PSJPAD:0
- SET PSJOQ=$ORDER(^PS(55,PSGP,5,"AUS",PSJOQ))
- if 'PSJOQ!(PSJOQ>PSGDT)
- QUIT
- SET UPD=PSJOQ
- Begin DoDot:1
- +2 FOR PSJOQQ=0:0
- SET PSJOQQ=$ORDER(^PS(55,PSGP,5,"AUS",PSJOQ,PSJOQQ))
- if 'PSJOQQ
- QUIT
- IF $DATA(^PS(55,PSGP,5,PSJOQQ,0))
- IF "DEH"'[$EXTRACT($PIECE(^(0),"^",9))
- Begin DoDot:2
- +3 NEW DIE,DA,DR,X,Y,QQON
- SET QQON=PSJOQQ
- SET DIE="^PS(55,"_PSGP_",5,"
- SET DA(1)=PSGP
- SET DA=+QQON
- SET DR="28////E"
- DO ^DIE
- +4 SET ORIFN=$PIECE(^PS(55,PSGP,5,+QQON,0),"^",21)
- DO EN1^PSJHL2(PSGP,"SC",QQON_"U")
- End DoDot:2
- End DoDot:1
- +5 KILL UPD,PSJOQ,PSJOQQ
- QUIT
- +6 ;
- EN(PSJPTYP) ; enter here
- +1 ; PSJPTYP=1:UD ONLY, 2:IV ONLY, 3:BOTH
- +2 NEW PSJX,PSJY
- +3 SET PSJDCEXP=$$RECDCEXP^PSJP()
- +4 ; Initialize if no 'View Profile' option selected
- SET PSJOL=$GET(PSJOL)
- +5 IF PSJOL="L"
- IF $DATA(XRTL)
- DO T0^%ZOSV
- +6 KILL ^TMP("PSJ",$JOB)
- DO NOW^%DTC
- SET PSGDT=+$EXTRACT(%,1,12)
- SET DT=$$DT^XLFDT
- SET PSJOS=$PIECE(PSJSYSP0,"^",11)
- SET UDU=$SELECT($PIECE(PSJSYSU,";",3)>1:3,1:1)
- +7 SET PSJOCNT=0
- IF PSJPTYP>1
- FOR PSJORD=0:0
- SET PSJORD=$ORDER(^PS(55,DFN,"IV",PSJORD))
- if 'PSJORD
- QUIT
- Begin DoDot:1
- +8 SET PSJX=$GET(^PS(55,DFN,"IV",+PSJORD,0))
- +9 SET PSJY=$PIECE(PSJX,U,17)
- +10 IF $PIECE(PSJX,U,3)<PSGDT
- IF "AR"[PSJY
- SET $PIECE(^PS(55,DFN,"IV",+PSJORD,0),U,17)="E"
- SET PSJY="E"
- SET ON=+PSJORD
- DO EXPIR^PSIVOE
- +11 IF +PSJSYSU=3
- IF ('+$PIECE($GET(^PS(55,DFN,"IV",+PSJORD,4)),U,4))
- IF ($PIECE($GET(^(.2)),U,4)="D")
- SET PSJPRI="D"
- +12 IF $SELECT($GET(PSJPRI)="D":1,PSJY="P":0,PSJOL="L":1,$PIECE(PSJX,U,3)>$PIECE($GET(PSJDCEXP),U,2):1,1:"DPE"'[PSJY)
- SET ON=+PSJORD_"V"
- DO IVSET
- KILL PSJPRI,ON
- End DoDot:1
- +13 DO NOW^%DTC
- SET PSJIVOF=PSJOCNT
- SET PSGDT=%
- SET (X1,DT)=$PIECE(%,".")
- SET X2=-2
- DO C^%DTC
- SET PSGODT=X_(PSGDT#1)
- SET HDT=$$ENDTC^PSGMI(PSGDT)
- +14 DO ENUNM
- +15 IF PSJPTYP'=2
- FOR ST="C","O","OC","P","R"
- FOR SD=0:0
- SET SD=$ORDER(^PS(55,PSGP,5,"AU",ST,SD))
- if 'SD
- QUIT
- FOR O=0:0
- SET O=$ORDER(^PS(55,PSGP,5,"AU",ST,SD,O))
- if 'O
- QUIT
- DO ECHK
- +16 if $DATA(PSGONNV)
- QUIT
- +17 ;I PSJPTYP'=2 F SD="I","N" S O=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=+O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D NVSET
- +18 NEW PRNTON
- FOR SD="I","N"
- SET (PRNTON,O)=0
- FOR
- SET O=$ORDER(^PS(53.1,"AS",SD,PSGP,O))
- if 'O
- QUIT
- SET ON=+O_"P"
- SET X=$PIECE($GET(^PS(53.1,+O,0)),U,4)
- IF $SELECT(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1)
- DO NVSET
- +19 ;I $S(+PSJSYSU=3:1,1:$D(PSGLPF)) S O=0,SD="P" F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=O_"P",X=$P($G(^PS(53.1,+O,0)),U,4) I $S(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1) D @$S("FI"[X:"IVSET",1:"NVSET")
- +20 NEW PRNTON
- SET (PRNTON,O)=0
- SET SD="P"
- FOR
- SET O=$ORDER(^PS(53.1,"AS",SD,PSGP,O))
- if 'O
- QUIT
- SET ON=O_"P"
- SET X=$PIECE($GET(^PS(53.1,+O,0)),U,4)
- IF $SELECT(PSJPTYP=3:1,PSJPTYP=1&("FI"[X):0,1:1)
- DO @$SELECT("FI"[X:"IVSET",1:"NVSET")
- +21 IF PSJOL="L"
- IF $DATA(XRT0)
- SET XRTN="PSJO1"
- DO T1^%ZOSV
- +22 DO CLEAN^PSJIMO1(PSGP)
- +23 QUIT
- +24 ;
- NVSET ; Set up orders from 53.1.
- +1 NEW ND
- SET ND=$GET(^PS(53.1,O,0))
- IF 'ND
- Begin DoDot:1
- +2 KILL ^PS(53.1,"AS",SD,PSGP,O)
- End DoDot:1
- QUIT
- +3 IF $PIECE(ND,U,15)
- IF $GET(PSGP)
- IF PSGP'=$PIECE(ND,U,15)
- Begin DoDot:1
- +4 KILL ^PS(53.1,"AS",SD,PSGP,O)
- End DoDot:1
- QUIT
- +5 IF $PIECE(ND,U,9)["D"
- Begin DoDot:1
- +6 KILL ^PS(53.1,"AS",SD,PSGP,O)
- +7 NEW ND2
- SET ND2=$GET(^PS(53.1,O,.2))
- IF $PIECE(ND2,U,8)
- KILL ^PS(53.1,"ACX",$PIECE(ND2,U,8))
- End DoDot:1
- QUIT
- +8 SET ST=$PIECE($GET(^PS(53.1,O,0)),U,7)
- SET START=-$PIECE($GET(^(2)),U,2)
- SET P("PRNTON")=$PIECE($GET(^PS(53.1,O,.2)),"^",8)
- if ST=""
- SET ST="z"
- +9 SET C=$SELECT(((SD="N")&($PIECE($GET(^PS(53.1,O,.2)),U,8)]"")):"BD",SD="N":"BA",SD="I":"BB",$PIECE($GET(^PS(53.1,O,.2)),U,8)]"":"CD",$PIECE($GET(^PS(53.1,O,.2)),U,4)="S":"CA",$PIECE($GET(^(0)),U,24)="R":"CC",1:"CB")
- +10 ;I C="CC" S C=$$CKPC^PSGOU(PSGP,+$P($G(^PS(53.1,O,0)),U,25),O)
- +11 DO SET
- +12 QUIT
- +13 ;
- KILL ;
- +1 KILL P,STAT,TYP,ORTX,N,JJ
- +2 QUIT
- COMCHK(PSJCOM,PSJPTYP) ;Check complex orders for order type
- +1 SET OK=0
- +2 IF PSJCOM=0
- SET OK=1
- QUIT OK
- +3 IF PSJCOM=""
- QUIT OK
- +4 IF PSJPTYP=""
- QUIT OK
- +5 IF '$DATA(^PS(53.1,"ACX",PSJCOM))
- QUIT OK
- +6 SET OK=1
- IF PSJPTYP=3
- QUIT OK
- +7 NEW PSJON
- SET PSJON=""
- +8 FOR
- SET PSJON=$ORDER(^PS(53.1,"ACX",PSJCOM,PSJON))
- if 'PSJON
- QUIT
- Begin DoDot:1
- +9 IF $PIECE($GET(^PS(53.1,PSJON,0)),"^",9)["D"
- KILL ^PS(53.1,"ACX",PSJCOM)
- +10 IF $PIECE($GET(^PS(53.1,PSJON,0)),"^",4)'="U"
- IF PSJPTYP=1
- SET OK=0
- QUIT
- +11 IF $PIECE($GET(^PS(53.1,PSJON,0)),"^",4)="U"
- IF PSJPTYP=2
- SET OK=0
- QUIT
- End DoDot:1
- if OK=0
- QUIT
- +12 QUIT OK
- +13 ;
- CLINIC(PSGP,ORDER) ; Return Clinic Name for a given patient/order combination
- +1 IF '$GET(ORDER)
- QUIT ""
- +2 NEW CLN
- SET CLN=$SELECT(ORDER["P":$GET(^PS(53.1,+ORDER,"DSS")),ORDER["V":$GET(^PS(55,PSGP,"IV",+ORDER,"DSS")),ORDER["U":$GET(^PS(55,PSGP,5,+ORDER,8)),1:"")
- +3 IF 'CLN
- IF (ORDER=+ORDER)
- Begin DoDot:1
- +4 IF $DATA(^PS(53.1,"ACX",+ORDER))
- NEW PSJORD
- SET PSJORD=0
- FOR
- SET PSJORD=$ORDER(^PS(53.1,"ACX",+ORDER,PSJORD))
- if 'PSJORD!$GET(CLN)
- QUIT
- SET CLN=$GET(^PS(53.1,+PSJORD,"DSS"))
- +5 IF $DATA(^PS(55,"ACX",+ORDER))
- NEW ACX2,PSJORD
- SET ACX2=""
- FOR
- SET ACX2=$ORDER(^PS(55,"ACX",+ORDER,ACX2))
- if 'ACX2!$GET(CLN)
- QUIT
- SET PSJORD=0
- FOR
- SET PSJORD=$ORDER(^PS(55,"ACX",+ORDER,ACX2,PSJORD))
- if 'PSJORD!$GET(CLN)
- QUIT
- Begin DoDot:2
- +6 SET CLN=$SELECT(PSJORD["P":$GET(^PS(53.1,+PSJORD,"DSS")),PSJORD["V":$GET(^PS(55,PSGP,"IV",+PSJORD,"DSS")),ORDER["U":$GET(^PS(55,PSGP,5,+PSJORD,8)),1:"")
- End DoDot:2
- End DoDot:1
- +7 SET CLN=$SELECT($PIECE(CLN,"^",2):$$GET1^DIQ(44,+CLN,.01),1:"")
- +8 QUIT CLN
- +9 ;
- CLINSORT(C) ; Return integer sort value based on order status
- +1 IF $PIECE(C,"^")="Cz"
- NEW CTMP
- SET CTMP=C
- NEW C
- SET C=$PIECE(CTMP,"^",4)
- +2 SET SORT=$SELECT($EXTRACT(C)="A":3,$EXTRACT(C)["C"!($EXTRACT(C)["P"):1,($EXTRACT(C)["B"):2,($EXTRACT(C)["DF"):4,1:5)
- +3 QUIT SORT