- PSGAP0 ;BIR/CML3-ACTION PROFILE ;20 May 98 / 12:36 PM
- ;;5.0;INPATIENT MEDICATIONS;**8,58,111,278,275**;16 DEC 97;Build 157
- ;
- ; Reference to ^PS(55 is supported by DBIA# 2191
- ;
- GOD ; gather order data
- N PSJCLN,CLINSORT
- 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),DRG=$G(^PS(50.7,+DRG,0))
- ;S NF=$P(DRG,"^",9)
- 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",40,0,.PSG,1)
- S DRG=PSG(1),DRG=$S(DRG["NOT FOUND":"z",1:DRG)
- S ST=$P(ND,"^",9),ND=$P(ND,"^",7),SD=$P(ND2,"^",2),FD=$P(ND2,"^",4)
- I STP'=9999999\1,(SD>STP) Q
- F X="SD","FD" S @X=$E($$ENDTC^PSGMI(@X),1,5)
- ;
- S Y=SI S:Y]"" Y=$$ENSET^PSGSICHK(Y)
- ; PSJ*5*275 get clinic
- S PSJCLN=$$CLINIC^PSJO1(PSGP,+PSJJORD_"U") I (PSJCLN]"") S PSGAWPDN="zz" S CLINSORT=$$CLINSORT^PSJO1($P(ND,"^",9))
- S X=$S(($G(PSJCLN)]""):"zz"_U_PSJCLN_U_CLINSORT_U_$E(DRG,1,20),1:ND_U_$E(DRG,1,20))
- ;
- S ^TMP($J,$E(PSGAPWDN,1,20),TM,PN,X,+PSJJORD)=ST_U_SD_U_FD_U_WS_U_SM_U_NF S:Y]"" ^(PSJJORD,1)=Y
- Q
- ;
- PAT ;
- S RB=$G(^DPT(PSGP,.101)) S:RB]"" TM=$S('$D(PSGAPTM):"zz",1:$O(^PS(57.7,"AWRT",PSGAPWD,RB,0))) S:$G(TM)="" TM="zz" I PSGAPWDN="" S PSGAPWDN="* NF *"
- I $D(PSGAPTM) S ATM="",ATM=$O(PSGAPTM(ATM)) I ATM'="ALL" Q:'$D(PSGAPTM(+TM))
- S:TM'="zz" TM=^PS(57.7,PSGAPWD,1,TM,0)
- S PSJACNWP=1 D PSJAC2^PSJAC(1),NOW^%DTC S PSGDT=%,PND=PSGP(0),PN=$S($G(PSJSEL("RBP"))="R":RB,1:"")_"^"_$E($P(PND,"^"),1,20)_"^"_PSGP
- I '$G(STT) S STT=PSGDT,STP=9999999
- S:PSGMTYPE[1 PSGMTYPE="2,3,4,5,6"
- I PSGMTYPE[2 D
- . F STRT=STT:0 S STRT=$O(^PS(55,PSGP,5,"AUS",STRT)) Q:'STRT F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,5,"AUS",STRT,PSJJORD)) Q:'PSJJORD D GOD
- . S XTYPE=2,PST="S" D ^PSGAPIV
- 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 ^PSGAPIV
- I PSGMTYPE[3 S XTYPE=3,PST="S" D ^PSGAPIV ;* Find syringe type iv
- I $D(^TMP($J,$E(PSGAPWDN,1,20),TM,PN)) D
- . S ^TMP($J,$E(PSGAPWDN,1,20),TM,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)_"^"_+PSJPWT
- . S:($G(PSJSEL("WG"))="^OTHER") ^TMP("PSGAP0",$J,"OUTPT",PSGP)=""
- Q
- ;
- GDT ;
- K %DT S %DT="EFTX",Y=-1,%DT(0)=$S(N["R":PSGDT,1:STT) F W !!,"Enter ",N," date/time: " R X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D DTM:X?1."?",^%DT Q:Y>0
- I X'="^" S:N["R" STT=$S(Y'>0:PSGDT,Y#1:+$E(Y,1,12),1:Y+.0002)-.0001 S:N["O" STP=$S(Y'>0:9999999,Y#1:+$E(Y,1,12),1:Y+.24)
- K %DT Q
- ;
- EN ; entry point
- K ^TMP($J) ;PSJ*5*278
- N CLIN,INDEX
- I PSGSS'="P" D NOW^%DTC S PSGDT=%,DT=$$DT^XLFDT F N="START","STOP" D GDT I X="^" S PSJSTOP=1 Q
- I PSGSS'="P" Q:X="^" S:'$P(STP,".",2) $P(STP,".",2)=24 S:'$P(STT,".",2) $P(STT,".",2)="0001"
- S PSJSTOP=$$MEDTYPE^PSJMDIR($G(PSGWD)) Q:PSJSTOP S PSGMTYPE=Y
- K ZTSAVE S:PSGSS'="P" (ZTSAVE("STT"),ZTSAVE("STP"))="" F X="PSGP","PSGSS","PSGAPWD","PSGAPWG","PSGAPWDN","PSGAPWGN","PSGPAT(","PSGAPTM(","PSGMTYPE","PSGPTMP","PSJSEL(","PSJOS","PPAGE" S ZTSAVE(X)=""
- W !,"...this may take a few minutes...(you should QUEUE this report)..."
- S PSGTIR="ENQ^PSGAP0",ZTDESC="ACTION PROFILE" D ENDEV^PSGTI S:POP PSJSTOP=1 Q:POP!$D(IO("Q"))
- ;
- ENQ ; queued entry point
- K ^TMP("PSGAP0",$J) N RB,ATM,TM,DRGI,DRGN,DRGT,ON,PST,PSIVUP,PSJORIFN,QST,SLS,XTYPE
- D @("P"_PSGSS),^PSGAPP D ^%ZISC K ^TMP("PSGAP0",$J)
- Q
- ;
- PG ;
- I $G(PSJSEL("WG"))="^OTHER" 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
- ;
- CLIN ;
- F INDEX="AIVC","AUDC" S STOP=0 F S STOP=$O(^PS(55,INDEX,STOP)) Q:'STOP S CLIN=0 F S CLIN=$O(^PS(55,INDEX,STOP,CLIN)) Q:'CLIN D
- . S DFN=0 F S DFN=$O(^PS(55,INDEX,STOP,CLIN,DFN)) Q:'DFN I '$D(^TMP("PSGAP0",$J,"OUTPT",DFN)) D
- .. S PSGP=DFN,Q=STOP N STOP D PAT
- Q
- ;
- PW ;
- F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGAPWDN,PSGP)) Q:'PSGP D
- .S Q=$O(^PS(55,PSGP,5,"AUS",STT)) I Q D PAT Q
- .S Q=$O(^PS(55,PSGP,"IV","AIS",STT)) I Q 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)) D PAT
- Q
- ;
- DTM ;
- N T
- S Y=%DT(0) D D^DIQ S T=$P(Y,"@",2),Y=$P(Y,",")
- W !!?2,"If a ",N," date is entered, an action profile will print for only those",!,"patients that have at least one active order with a ",$S(N["A":"STOP",1:"START")," DATE on or ",$S(N["A":"after",1:"before"),!,"the ",N," date entered."
- W !?2,"Entry is not required. If neither date is entered, all patients with active",!,"orders will print (for the ward(s) chosen). Enter an up-arrow (^) to exit."
- W !?2,"If you wish to enter a ",$S(N["R":"start",1:"stop")," date of ",Y,", you must enter a TIME of day",!,"of ",T," or greater. Any date after ",Y," does not need time entered.",! S Y=-1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGAP0 4997 printed Mar 13, 2025@21:05:40 Page 2
- PSGAP0 ;BIR/CML3-ACTION PROFILE ;20 May 98 / 12:36 PM
- +1 ;;5.0;INPATIENT MEDICATIONS;**8,58,111,278,275**;16 DEC 97;Build 157
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA# 2191
- +4 ;
- GOD ; gather order data
- +1 NEW PSJCLN,CLINSORT
- +2 ;WS=$S(DRG&PSGAPWD:$D(^PSI(58.1,"D",+DRG,PSGAPWD)),1:0),DRG=$G(^PS(50.7,+DRG,0))
- SET ND=$GET(^PS(55,PSGP,5,PSJJORD,0))
- SET ND2=$GET(^(2))
- SET SI=$PIECE($GET(^(6)),"^")
- SET DRG=$GET(^(.2))
- +3 ;S NF=$P(DRG,"^",9)
- +4 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)
- +5 NEW X,PSG
- +6 DO DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",40,0,.PSG,1)
- +7 SET DRG=PSG(1)
- SET DRG=$SELECT(DRG["NOT FOUND":"z",1:DRG)
- +8 SET ST=$PIECE(ND,"^",9)
- SET ND=$PIECE(ND,"^",7)
- SET SD=$PIECE(ND2,"^",2)
- SET FD=$PIECE(ND2,"^",4)
- +9 IF STP'=9999999\1
- IF (SD>STP)
- QUIT
- +10 FOR X="SD","FD"
- SET @X=$EXTRACT($$ENDTC^PSGMI(@X),1,5)
- +11 ;
- +12 SET Y=SI
- if Y]""
- SET Y=$$ENSET^PSGSICHK(Y)
- +13 ; PSJ*5*275 get clinic
- +14 SET PSJCLN=$$CLINIC^PSJO1(PSGP,+PSJJORD_"U")
- IF (PSJCLN]"")
- SET PSGAWPDN="zz"
- SET CLINSORT=$$CLINSORT^PSJO1($PIECE(ND,"^",9))
- +15 SET X=$SELECT(($GET(PSJCLN)]""):"zz"_U_PSJCLN_U_CLINSORT_U_$EXTRACT(DRG,1,20),1:ND_U_$EXTRACT(DRG,1,20))
- +16 ;
- +17 SET ^TMP($JOB,$EXTRACT(PSGAPWDN,1,20),TM,PN,X,+PSJJORD)=ST_U_SD_U_FD_U_WS_U_SM_U_NF
- if Y]""
- SET ^(PSJJORD,1)=Y
- +18 QUIT
- +19 ;
- PAT ;
- +1 SET RB=$GET(^DPT(PSGP,.101))
- if RB]""
- SET TM=$SELECT('$DATA(PSGAPTM):"zz",1:$ORDER(^PS(57.7,"AWRT",PSGAPWD,RB,0)))
- if $GET(TM)=""
- SET TM="zz"
- IF PSGAPWDN=""
- SET PSGAPWDN="* NF *"
- +2 IF $DATA(PSGAPTM)
- SET ATM=""
- SET ATM=$ORDER(PSGAPTM(ATM))
- IF ATM'="ALL"
- if '$DATA(PSGAPTM(+TM))
- QUIT
- +3 if TM'="zz"
- SET TM=^PS(57.7,PSGAPWD,1,TM,0)
- +4 SET PSJACNWP=1
- DO PSJAC2^PSJAC(1)
- DO NOW^%DTC
- SET PSGDT=%
- SET PND=PSGP(0)
- SET PN=$SELECT($GET(PSJSEL("RBP"))="R":RB,1:"")_"^"_$EXTRACT($PIECE(PND,"^"),1,20)_"^"_PSGP
- +5 IF '$GET(STT)
- SET STT=PSGDT
- SET STP=9999999
- +6 if PSGMTYPE[1
- SET PSGMTYPE="2,3,4,5,6"
- +7 IF PSGMTYPE[2
- Begin DoDot:1
- +8 FOR STRT=STT:0
- SET STRT=$ORDER(^PS(55,PSGP,5,"AUS",STRT))
- if 'STRT
- QUIT
- FOR PSJJORD=0:0
- SET PSJJORD=$ORDER(^PS(55,PSGP,5,"AUS",STRT,PSJJORD))
- if 'PSJJORD
- QUIT
- DO GOD
- +9 SET XTYPE=2
- SET PST="S"
- DO ^PSGAPIV
- End DoDot:1
- +10 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 ^PSGAPIV
- +11 ;* Find syringe type iv
- IF PSGMTYPE[3
- SET XTYPE=3
- SET PST="S"
- DO ^PSGAPIV
- +12 IF $DATA(^TMP($JOB,$EXTRACT(PSGAPWDN,1,20),TM,PN))
- Begin DoDot:1
- +13 SET ^TMP($JOB,$EXTRACT(PSGAPWDN,1,20),TM,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)_"^"_+PSJPWT
- +14 if ($GET(PSJSEL("WG"))="^OTHER")
- SET ^TMP("PSGAP0",$JOB,"OUTPT",PSGP)=""
- End DoDot:1
- +15 QUIT
- +16 ;
- GDT ;
- +1 KILL %DT
- SET %DT="EFTX"
- SET Y=-1
- SET %DT(0)=$SELECT(N["R":PSGDT,1:STT)
- FOR
- WRITE !!,"Enter ",N," date/time: "
- READ X:DTIME
- if '$TEST
- WRITE $CHAR(7)
- if '$TEST
- SET X="^"
- if "^"[X
- QUIT
- if X?1."?"
- DO DTM
- DO ^%DT
- if Y>0
- QUIT
- +2 IF X'="^"
- if N["R"
- SET STT=$SELECT(Y'>0:PSGDT,Y#1:+$EXTRACT(Y,1,12),1:Y+.0002)-.0001
- if N["O"
- SET STP=$SELECT(Y'>0:9999999,Y#1:+$EXTRACT(Y,1,12),1:Y+.24)
- +3 KILL %DT
- QUIT
- +4 ;
- EN ; entry point
- +1 ;PSJ*5*278
- KILL ^TMP($JOB)
- +2 NEW CLIN,INDEX
- +3 IF PSGSS'="P"
- DO NOW^%DTC
- SET PSGDT=%
- SET DT=$$DT^XLFDT
- FOR N="START","STOP"
- DO GDT
- IF X="^"
- SET PSJSTOP=1
- QUIT
- +4 IF PSGSS'="P"
- if X="^"
- QUIT
- if '$PIECE(STP,".",2)
- SET $PIECE(STP,".",2)=24
- if '$PIECE(STT,".",2)
- SET $PIECE(STT,".",2)="0001"
- +5 SET PSJSTOP=$$MEDTYPE^PSJMDIR($GET(PSGWD))
- if PSJSTOP
- QUIT
- SET PSGMTYPE=Y
- +6 KILL ZTSAVE
- if PSGSS'="P"
- SET (ZTSAVE("STT"),ZTSAVE("STP"))=""
- FOR X="PSGP","PSGSS","PSGAPWD","PSGAPWG","PSGAPWDN","PSGAPWGN","PSGPAT(","PSGAPTM(","PSGMTYPE","PSGPTMP","PSJSEL(","PSJOS","PPAGE"
- SET ZTSAVE(X)=""
- +7 WRITE !,"...this may take a few minutes...(you should QUEUE this report)..."
- +8 SET PSGTIR="ENQ^PSGAP0"
- SET ZTDESC="ACTION PROFILE"
- DO ENDEV^PSGTI
- if POP
- SET PSJSTOP=1
- if POP!$DATA(IO("Q"))
- QUIT
- +9 ;
- ENQ ; queued entry point
- +1 KILL ^TMP("PSGAP0",$JOB)
- NEW RB,ATM,TM,DRGI,DRGN,DRGT,ON,PST,PSIVUP,PSJORIFN,QST,SLS,XTYPE
- +2 DO @("P"_PSGSS)
- DO ^PSGAPP
- DO ^%ZISC
- KILL ^TMP("PSGAP0",$JOB)
- +3 QUIT
- +4 ;
- PG ;
- +1 IF $GET(PSJSEL("WG"))="^OTHER"
- 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 ;
- CLIN ;
- +1 FOR INDEX="AIVC","AUDC"
- SET STOP=0
- FOR
- SET STOP=$ORDER(^PS(55,INDEX,STOP))
- if 'STOP
- QUIT
- SET CLIN=0
- FOR
- SET CLIN=$ORDER(^PS(55,INDEX,STOP,CLIN))
- if 'CLIN
- QUIT
- Begin DoDot:1
- +2 SET DFN=0
- FOR
- SET DFN=$ORDER(^PS(55,INDEX,STOP,CLIN,DFN))
- if 'DFN
- QUIT
- IF '$DATA(^TMP("PSGAP0",$JOB,"OUTPT",DFN))
- Begin DoDot:2
- +3 SET PSGP=DFN
- SET Q=STOP
- NEW STOP
- DO PAT
- End DoDot:2
- End DoDot:1
- +4 QUIT
- +5 ;
- PW ;
- +1 FOR PSGP=0:0
- SET PSGP=$ORDER(^DPT("CN",PSGAPWDN,PSGP))
- if 'PSGP
- QUIT
- Begin DoDot:1
- +2 SET Q=$ORDER(^PS(55,PSGP,5,"AUS",STT))
- IF Q
- DO PAT
- QUIT
- +3 SET Q=$ORDER(^PS(55,PSGP,"IV","AIS",STT))
- IF Q
- DO PAT
- End DoDot:1
- +4 QUIT
- +5 ;
- 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))
- DO PAT
- +2 QUIT
- +3 ;
- DTM ;
- +1 NEW T
- +2 SET Y=%DT(0)
- DO D^DIQ
- SET T=$PIECE(Y,"@",2)
- SET Y=$PIECE(Y,",")
- +3 WRITE !!?2,"If a ",N," date is entered, an action profile will print for only those",!,"patients that have at least one active order with a ",$SELECT(N["A":"STOP",1:"START")," DATE on or ",$SELECT(N["A":"after",1:"before"),!,"the ",N," date ent
- ered."
- +4 WRITE !?2,"Entry is not required. If neither date is entered, all patients with active",!,"orders will print (for the ward(s) chosen). Enter an up-arrow (^) to exit."
- +5 WRITE !?2,"If you wish to enter a ",$SELECT(N["R":"start",1:"stop")," date of ",Y,", you must enter a TIME of day",!,"of ",T," or greater. Any date after ",Y," does not need time entered.",!
- SET Y=-1
- QUIT
