- PSGCAP0 ;BIR/CML3-ACTION PROFILE ;12 Mar 98 / 9:30 AM
- ;;5.0;INPATIENT MEDICATIONS;**8,58,111,149,275,301**;16 DEC 97;Build 3
- ;
- ; Reference to ^PS(55 is supported by DBIA# 2191
- ; Reference to ^PSDRUG is supported by DBIA# 2192
- ;
- GOD ; gather order data
- S ND=$G(^PS(55,PSGP,5,PSJJORD,0)),ND2=$G(^(2)),SI=$P($G(^(6)),"^"),DRG=$G(^(.2)) ;WS=$S(DRG&PSGAPWD:$D(^PSI(58.1,"D",+DRG,PSGAPWD)),1:0)
- S X=$$NFWS^PSJUTL1(PSGP,PSJJORD_"U",PSGAPWD) S NF=$P(X,U),WS=$P(X,U,2),SM=$S('$P(X,U,3):0,$P(X,U,4):1,1:2)
- N X,PSG
- D DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",20,0,.PSG,1)
- S DRG=PSG(1),DRG=$S(DRG["NOT FOUND":"z",1:DRG) ;SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2)
- S ST=$S($P(ND,U,27)="R"&($P(ND,U,9)="A"):"R",1:$P(ND,U,9)),ND=$P(ND,"^",7)
- N DDRG S (X,DCU)=0 F S X=$O(^PS(55,PSGP,5,PSJJORD,1,X)) Q:'X S DDRG=^(X,0),DCU=DCU+($P($G(^PSDRUG(+DDRG,660)),"^",6)*($S($P(DDRG,"^",2):$P(DDRG,"^",2),1:1)))
- ;
- ; PSJ*5*275 get clinic
- ;S PSGAPWDN="zz"
- N PSJCLN,CLINSORT S PSJCLN=$$CLINIC^PSJO1(PSGP,PSJJORD_"U")
- ; When run by Clinic, if patient also has Inpatient orders, make sure those orders have a corresponding patient node in ^TMP
- I PSJCLN="",($G(PSGSS)["C"),$G(PSJPWD),($G(PSJPWDN)]"") N PSGAPWDN,PSGAPWD S PSGAPWD=PSJPWD,PSGAPWDN=PSJPWDN D
- .S ^TMP($J,S1,PSGAPWDN,PN)=$P(PSJPSEX,"^",2)_"^"_$E($P(PSJPDOB,"^",2),1,10)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_$S(PSJPRB]"":PSJPRB,1:"*NF*")_"^"_$E($P(PSJPAD,"^",2),1,10)_"^"_$E($P(PSJPTD,"^",2),1,10)
- .S ^TMP($J,S1,PSGAPWDN,PN)=^(PN)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$P(PSGP(0),"^")
- I (PSJCLN]"") S CLINSORT=$$CLINSORT^PSJO1($G(ST)) I CLINSORT N:($G(PSGSS)'["C") PSGAPWDN S PSGAPWDN="zz"_U_PSJCLN_U_CLINSORT_U_ST
- ;
- S SD=$P(ND2,"^",2),FD=$P(ND2,"^",4) F X="SD","FD" S @X=$E($$ENDTC^PSGMI(@X),1,5)
- ;
- S Y=SI S:Y]"" Y=$$ENSET^PSGSICHK(Y)
- S PSGAPWDN=$S($P($G(PSGAPWDN),"^")="zz"&($P($G(PSGAPWDN),"^",2)'=""):PSGAPWDN,$G(PSGAPWD)="zz":"zz",$G(PSGAPWDN):PSGAPWDN,'$G(PSGAPWDN)&($G(PSJPWDN)'=""):PSJPWDN,1:"zz")
- S ^TMP($J,S1,PSGAPWDN,PN,ND_"^"_DRG,PSJJORD)=ST_"^"_SD_"^"_FD_"^"_WS_"^"_SM_"^"_NF_"^"_DCU_"^"_DRG S:Y]"" ^(PSJJORD,1)=Y Q
- ;
- PAT ;
- D PSJAC2^PSJAC(1),NOW^%DTC S PSGDT=%,PN=$E($P(PSGP(0),"^"),1,20)_"^"_PSGP
- S S1="zz" I PSGAPS="T",PSJPWD,PSJPRB]"",$D(^PS(57.7,PSJPWD,1,+$O(^PS(57.7,"AWRT",PSJPWD,PSJPRB,0)),0)),$P(^(0),"^")]"" S S1=$P(^(0),"^")
- I PSGAPS="P",PSJPTSP,$D(^VA(200,PSJPTSP,0)),$P(^(0),"^")]"" S S1=$P(^(0),"^")
- S:PSGMTYPE[1 PSGMTYPE="2,3,4,5,6"
- I PSGMTYPE[2 D
- . F STRT=PSGAPSD-.0001:0 S STRT=$O(^PS(55,PSGP,5,"AUS",STRT)) Q:$S('STRT:1,PSGAPO="E":STRT>PSGAPFD,1:0) I STRT'=PSGAPSD F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,5,"AUS",STRT,PSJJORD)) Q:'PSJJORD D GOD
- . S XTYPE=2,PST="S" D ^PSGCAPIV
- N XTYPE F XTYPE=3:1:6 I PSGMTYPE[XTYPE S PST=$S(XTYPE=3:"P",XTYPE=4:"A",XTYPE=5:"H",1:"C") D ^PSGCAPIV
- I PSGMTYPE[3 S XTYPE=3,PST="S" D ^PSGCAPIV ;* Find syringe type iv
- I $D(^TMP($J,S1,PSGAPWDN,PN)) S ^(PN)=$P(PSJPSEX,"^",2)_"^"_$E($P(PSJPDOB,"^",2),1,10)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_$S(PSJPRB]"":PSJPRB,1:"*NF*")_"^"_$E($P(PSJPAD,"^",2),1,10)_"^"_$E($P(PSJPTD,"^",2),1,10)
- I S ^TMP($J,S1,PSGAPWDN,PN)=^(PN)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$P(PSGP(0),"^")
- Q
- ;
- ENQ ; queued entry point
- N ALFLG,DCU,DRGI,DRGN,DRGT,KKA,HT,HTD,ON,PST,PSIVUP,PSJORIFN,QST,WTD,XTYPE
- K ^TMP($J) S STT=PSGAPSD-.0001,PSJACNWP=1 D @("P"_PSGSS),^PSGCAPP D ^%ZISC
- Q
- ;
- PG ;
- I PSGAPWD="zz" D CLIN Q
- F PSGAPWD=0:0 S PSGAPWD=$O(^PS(57.5,"AC",PSGAPWG,PSGAPWD)) Q:'PSGAPWD I $D(^DIC(42,PSGAPWD,0)),$P(^(0),"^")]"" S PSGAPWDN=$P(^(0),"^") D PW
- Q
- ;
- PW ;
- F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGAPWDN,PSGP)) Q:'PSGP D PAT
- Q
- ;
- PP ;
- F PSGP=0:0 S PSGP=$O(PSGPAT(PSGP)) Q:'PSGP S PSGAPWDN=$P($G(^DPT(PSGP,.1)),"^") S:PSGAPWDN]"" PSGAPWD=+$O(^DIC(42,"B",PSGAPWDN,0)) S:PSGAPWDN="" PSGAPWDN="zz" D PAT
- Q
- ;
- PL S CL="" F S CL=$O(^PS(57.8,"AD",CG,CL)) Q:CL="" D PC
- Q
- PC S PSGAPWDN=$S($D(^SC(CL,0)):$P(^(0),"^"),1:"")
- S PSGP="" F S PSGP=$O(^PS(53.1,"AD",CL,PSGP)) Q:PSGP="" D PAT
- N INDEX,APSTOP
- F INDEX="AIVC","AUDC" S APSTOP=0 F S APSTOP=$O(^PS(55,INDEX,APSTOP)) Q:'APSTOP D
- . S DFN=0 F S DFN=$O(^PS(55,INDEX,APSTOP,CL,DFN)) Q:'DFN I '$D(^TMP("PSGAP0",$J,"OUTPT",DFN)) S PSGP=DFN,Q=APSTOP,PSGAPWD="zz" D PAT
- Q
- CLIN ;
- N INDEX,APSTOP,CLIN
- F INDEX="AIVC","AUDC" S APSTOP=0 F S APSTOP=$O(^PS(55,INDEX,APSTOP)) Q:'APSTOP S CLIN=0 F S CLIN=$O(^PS(55,INDEX,APSTOP,CLIN)) Q:'CLIN D
- . S DFN=0 F S DFN=$O(^PS(55,INDEX,APSTOP,CLIN,DFN)) Q:'DFN I '$D(^TMP("PSGAP0",$J,"OUTPT",DFN)) S PSGP=DFN,Q=APSTOP,PSGAPWD="zz" D PAT
- Q
- ;
- SETPI(PSGP) ; Set Patient Information for clinic orders when run by Ward
- N PSJCLPIN D PSJAC2^PSJAC(1)
- S PSJCLPIN=$P($G(PSJPSEX),"^",2)_"^"_$E($P($G(PSJPDOB),"^",2),1,10)_";"_$G(PSJPAGE)_"^"_$G(VA("PID"))_"^"_$G(PSJPDX)_"^"_$S($G(PSJPRB)]"":$G(PSJPRB),1:"*NF*")
- Q PSJCLPIN_"^"_$E($P($G(PSJPAD),"^",2),1,10)_"^"_$E($P(PSJPTD,"^",2),1,10)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$P(PSGP(0),"^")
- ENOR ;
- D ENCV^PSGSETU I $D(XQUIT) Q
- S (DFN,PSGP)=+ORVP D ^PSJAC S PSGPAT=PSGP,PSGPAT(DFN)="",(PSGAP,PSGAPWD,PSGAPWG)=0,(PSGAPWDN,PSGAPWGN)="",PSGSS="P" D ORS^PSGCAP S PSJNKF=1 D DONE^PSGCAP Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGCAP0 5203 printed Feb 18, 2025@23:27:17 Page 2
- PSGCAP0 ;BIR/CML3-ACTION PROFILE ;12 Mar 98 / 9:30 AM
- +1 ;;5.0;INPATIENT MEDICATIONS;**8,58,111,149,275,301**;16 DEC 97;Build 3
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA# 2191
- +4 ; Reference to ^PSDRUG is supported by DBIA# 2192
- +5 ;
- GOD ; gather order data
- +1 ;WS=$S(DRG&PSGAPWD:$D(^PSI(58.1,"D",+DRG,PSGAPWD)),1:0)
- SET ND=$GET(^PS(55,PSGP,5,PSJJORD,0))
- SET ND2=$GET(^(2))
- SET SI=$PIECE($GET(^(6)),"^")
- SET DRG=$GET(^(.2))
- +2 SET X=$$NFWS^PSJUTL1(PSGP,PSJJORD_"U",PSGAPWD)
- SET NF=$PIECE(X,U)
- SET WS=$PIECE(X,U,2)
- SET SM=$SELECT('$PIECE(X,U,3):0,$PIECE(X,U,4):1,1:2)
- +3 NEW X,PSG
- +4 DO DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",20,0,.PSG,1)
- +5 ;SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2)
- SET DRG=PSG(1)
- SET DRG=$SELECT(DRG["NOT FOUND":"z",1:DRG)
- +6 SET ST=$SELECT($PIECE(ND,U,27)="R"&($PIECE(ND,U,9)="A"):"R",1:$PIECE(ND,U,9))
- SET ND=$PIECE(ND,"^",7)
- +7 NEW DDRG
- SET (X,DCU)=0
- FOR
- SET X=$ORDER(^PS(55,PSGP,5,PSJJORD,1,X))
- if 'X
- QUIT
- SET DDRG=^(X,0)
- SET DCU=DCU+($PIECE($GET(^PSDRUG(+DDRG,660)),"^",6)*($SELECT($PIECE(DDRG,"^",2):$PIECE(DDRG,"^",2),1:1)))
- +8 ;
- +9 ; PSJ*5*275 get clinic
- +10 ;S PSGAPWDN="zz"
- +11 NEW PSJCLN,CLINSORT
- SET PSJCLN=$$CLINIC^PSJO1(PSGP,PSJJORD_"U")
- +12 ; When run by Clinic, if patient also has Inpatient orders, make sure those orders have a corresponding patient node in ^TMP
- +13 IF PSJCLN=""
- IF ($GET(PSGSS)["C")
- IF $GET(PSJPWD)
- IF ($GET(PSJPWDN)]"")
- NEW PSGAPWDN,PSGAPWD
- SET PSGAPWD=PSJPWD
- SET PSGAPWDN=PSJPWDN
- Begin DoDot:1
- +14 SET ^TMP($JOB,S1,PSGAPWDN,PN)=$PIECE(PSJPSEX,"^",2)_"^"_$EXTRACT($PIECE(PSJPDOB,"^",2),1,10)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_$SELECT(PSJPRB]"":PSJPRB,1:"*NF*")_"^"_$EXTRACT($PIECE(PSJPAD,"^",2),1,10)_"^"_$EXTRACT($P
- IECE(PSJPTD,"^",2),1,10)
- +15 SET ^TMP($JOB,S1,PSGAPWDN,PN)=^(PN)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$PIECE(PSGP(0),"^")
- End DoDot:1
- +16 IF (PSJCLN]"")
- SET CLINSORT=$$CLINSORT^PSJO1($GET(ST))
- IF CLINSORT
- if ($GET(PSGSS)'["C")
- NEW PSGAPWDN
- SET PSGAPWDN="zz"_U_PSJCLN_U_CLINSORT_U_ST
- +17 ;
- +18 SET SD=$PIECE(ND2,"^",2)
- SET FD=$PIECE(ND2,"^",4)
- FOR X="SD","FD"
- SET @X=$EXTRACT($$ENDTC^PSGMI(@X),1,5)
- +19 ;
- +20 SET Y=SI
- if Y]""
- SET Y=$$ENSET^PSGSICHK(Y)
- +21 SET PSGAPWDN=$SELECT($PIECE($GET(PSGAPWDN),"^")="zz"&($PIECE($GET(PSGAPWDN),"^",2)'=""):PSGAPWDN,$GET(PSGAPWD)="zz":"zz",$GET(PSGAPWDN):PSGAPWDN,'$GET(PSGAPWDN)&($GET(PSJPWDN)'=""):PSJPWDN,1:"zz")
- +22 SET ^TMP($JOB,S1,PSGAPWDN,PN,ND_"^"_DRG,PSJJORD)=ST_"^"_SD_"^"_FD_"^"_WS_"^"_SM_"^"_NF_"^"_DCU_"^"_DRG
- if Y]""
- SET ^(PSJJORD,1)=Y
- QUIT
- +23 ;
- PAT ;
- +1 DO PSJAC2^PSJAC(1)
- DO NOW^%DTC
- SET PSGDT=%
- SET PN=$EXTRACT($PIECE(PSGP(0),"^"),1,20)_"^"_PSGP
- +2 SET S1="zz"
- IF PSGAPS="T"
- IF PSJPWD
- IF PSJPRB]""
- IF $DATA(^PS(57.7,PSJPWD,1,+$ORDER(^PS(57.7,"AWRT",PSJPWD,PSJPRB,0)),0))
- IF $PIECE(^(0),"^")]""
- SET S1=$PIECE(^(0),"^")
- +3 IF PSGAPS="P"
- IF PSJPTSP
- IF $DATA(^VA(200,PSJPTSP,0))
- IF $PIECE(^(0),"^")]""
- SET S1=$PIECE(^(0),"^")
- +4 if PSGMTYPE[1
- SET PSGMTYPE="2,3,4,5,6"
- +5 IF PSGMTYPE[2
- Begin DoDot:1
- +6 FOR STRT=PSGAPSD-.0001:0
- SET STRT=$ORDER(^PS(55,PSGP,5,"AUS",STRT))
- if $SELECT('STRT
- QUIT
- IF STRT'=PSGAPSD
- FOR PSJJORD=0:0
- SET PSJJORD=$ORDER(^PS(55,PSGP,5,"AUS",STRT,PSJJORD))
- if 'PSJJORD
- QUIT
- DO GOD
- +7 SET XTYPE=2
- SET PST="S"
- DO ^PSGCAPIV
- End DoDot:1
- +8 NEW XTYPE
- FOR XTYPE=3:1:6
- IF PSGMTYPE[XTYPE
- SET PST=$SELECT(XTYPE=3:"P",XTYPE=4:"A",XTYPE=5:"H",1:"C")
- DO ^PSGCAPIV
- +9 ;* Find syringe type iv
- IF PSGMTYPE[3
- SET XTYPE=3
- SET PST="S"
- DO ^PSGCAPIV
- +10 IF $DATA(^TMP($JOB,S1,PSGAPWDN,PN))
- SET ^(PN)=$PIECE(PSJPSEX,"^",2)_"^"_$EXTRACT($PIECE(PSJPDOB,"^",2),1,10)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_$SELECT(PSJPRB]"":PSJPRB,1:"*NF*")_"^"_$EXTRACT($PIECE(PSJPAD,"^",2),1,10)_"^"_$EXTRACT($PIECE(PSJPTD,"^",2),1,10)
- +11 IF $TEST
- SET ^TMP($JOB,S1,PSGAPWDN,PN)=^(PN)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$PIECE(PSGP(0),"^")
- +12 QUIT
- +13 ;
- ENQ ; queued entry point
- +1 NEW ALFLG,DCU,DRGI,DRGN,DRGT,KKA,HT,HTD,ON,PST,PSIVUP,PSJORIFN,QST,WTD,XTYPE
- +2 KILL ^TMP($JOB)
- SET STT=PSGAPSD-.0001
- SET PSJACNWP=1
- DO @("P"_PSGSS)
- DO ^PSGCAPP
- DO ^%ZISC
- +3 QUIT
- +4 ;
- PG ;
- +1 IF PSGAPWD="zz"
- DO CLIN
- QUIT
- +2 FOR PSGAPWD=0:0
- SET PSGAPWD=$ORDER(^PS(57.5,"AC",PSGAPWG,PSGAPWD))
- if 'PSGAPWD
- QUIT
- IF $DATA(^DIC(42,PSGAPWD,0))
- IF $PIECE(^(0),"^")]""
- SET PSGAPWDN=$PIECE(^(0),"^")
- DO PW
- +3 QUIT
- +4 ;
- PW ;
- +1 FOR PSGP=0:0
- SET PSGP=$ORDER(^DPT("CN",PSGAPWDN,PSGP))
- if 'PSGP
- QUIT
- DO PAT
- +2 QUIT
- +3 ;
- PP ;
- +1 FOR PSGP=0:0
- SET PSGP=$ORDER(PSGPAT(PSGP))
- if 'PSGP
- QUIT
- SET PSGAPWDN=$PIECE($GET(^DPT(PSGP,.1)),"^")
- if PSGAPWDN]""
- SET PSGAPWD=+$ORDER(^DIC(42,"B",PSGAPWDN,0))
- if PSGAPWDN=""
- SET PSGAPWDN="zz"
- DO PAT
- +2 QUIT
- +3 ;
- PL SET CL=""
- FOR
- SET CL=$ORDER(^PS(57.8,"AD",CG,CL))
- if CL=""
- QUIT
- DO PC
- +1 QUIT
- PC SET PSGAPWDN=$SELECT($DATA(^SC(CL,0)):$PIECE(^(0),"^"),1:"")
- +1 SET PSGP=""
- FOR
- SET PSGP=$ORDER(^PS(53.1,"AD",CL,PSGP))
- if PSGP=""
- QUIT
- DO PAT
- +2 NEW INDEX,APSTOP
- +3 FOR INDEX="AIVC","AUDC"
- SET APSTOP=0
- FOR
- SET APSTOP=$ORDER(^PS(55,INDEX,APSTOP))
- if 'APSTOP
- QUIT
- Begin DoDot:1
- +4 SET DFN=0
- FOR
- SET DFN=$ORDER(^PS(55,INDEX,APSTOP,CL,DFN))
- if 'DFN
- QUIT
- IF '$DATA(^TMP("PSGAP0",$JOB,"OUTPT",DFN))
- SET PSGP=DFN
- SET Q=APSTOP
- SET PSGAPWD="zz"
- DO PAT
- End DoDot:1
- +5 QUIT
- CLIN ;
- +1 NEW INDEX,APSTOP,CLIN
- +2 FOR INDEX="AIVC","AUDC"
- SET APSTOP=0
- FOR
- SET APSTOP=$ORDER(^PS(55,INDEX,APSTOP))
- if 'APSTOP
- QUIT
- SET CLIN=0
- FOR
- SET CLIN=$ORDER(^PS(55,INDEX,APSTOP,CLIN))
- if 'CLIN
- QUIT
- Begin DoDot:1
- +3 SET DFN=0
- FOR
- SET DFN=$ORDER(^PS(55,INDEX,APSTOP,CLIN,DFN))
- if 'DFN
- QUIT
- IF '$DATA(^TMP("PSGAP0",$JOB,"OUTPT",DFN))
- SET PSGP=DFN
- SET Q=APSTOP
- SET PSGAPWD="zz"
- DO PAT
- End DoDot:1
- +4 QUIT
- +5 ;
- SETPI(PSGP) ; Set Patient Information for clinic orders when run by Ward
- +1 NEW PSJCLPIN
- DO PSJAC2^PSJAC(1)
- +2 SET PSJCLPIN=$PIECE($GET(PSJPSEX),"^",2)_"^"_$EXTRACT($PIECE($GET(PSJPDOB),"^",2),1,10)_";"_$GET(PSJPAGE)_"^"_$GET(VA("PID"))_"^"_$GET(PSJPDX)_"^"_$SELECT($GET(PSJPRB)]"":$GET(PSJPRB),1:"*NF*")
- +3 QUIT PSJCLPIN_"^"_$EXTRACT($PIECE($GET(PSJPAD),"^",2),1,10)_"^"_$EXTRACT($PIECE(PSJPTD,"^",2),1,10)_"^"_PSJPWT_"^"_PSJPWTD_"^"_PSJPHT_"^"_PSJPHTD_"^"_$PIECE(PSGP(0),"^")
- ENOR ;
- +1 DO ENCV^PSGSETU
- IF $DATA(XQUIT)
- QUIT
- +2 SET (DFN,PSGP)=+ORVP
- DO ^PSJAC
- SET PSGPAT=PSGP
- SET PSGPAT(DFN)=""
- SET (PSGAP,PSGAPWD,PSGAPWG)=0
- SET (PSGAPWDN,PSGAPWGN)=""
- SET PSGSS="P"
- DO ORS^PSGCAP
- SET PSJNKF=1
- DO DONE^PSGCAP
- QUIT
