- PSORXEDT ;BIR/SAB - Edit RX Routine ;Jan 05, 2021@12:04
- ;;7.0;OUTPATIENT PHARMACY;**21,23,44,71,146,185,148,253,390,372,416,313,427,422,402,500,482,556,622,753**;DEC 1997;Build 53
- ;External Reference to ^PS(55 supported by DBIA 2228
- ;External reference to $$BSA^PSSDSAPI supported by DBIA 5425
- D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) G EOJ Q
- K PSODRUG,PSOLIST,DIR,DIRUT,DUOUT,X,Y,PSOFROM,^TMP("PSOBEDT",$J),NOPP,CLOZPST,PSOTITRX,PSOMTFLG
- N PSOODOSP
- W !! S DIR(0)="FAO^1:245",DIR("A")="Edit Rx(s) => ",DIR("?",1)="Enter Rx Number or A List of numbers Separated",DIR("?")="by Commas, e.g. 1234A,345,937002Q."
- D ^DIR K DIR G:$D(DIRUT) EOJ
- S END=$L(X,","),BAD=0
- F I=1:1:END S RXM=$P(X,",",I) I +RXM F J=I+1:1:END S DUP=$P(X,",",J) I DUP=RXM S $P(X,",",J)="" W !?5,$C(7),"Duplicate Rx # "_RXM_" was found in your list, ignoring it!",! S BAD=1
- S PSORLST=$P(X,",") F I=2:1:END S RXM=$P(X,",",I) S:RXM'?1.N.A BAD=1 I RXM?1.N.A S PSORLST=PSORLST_","_RXM
- F I=1:1:$L(PSORLST) S RXM=$P(PSORLST,",",I) I +RXM F J=I+1:1:END S DUP=$P(PSORLST,",",J) I DUP=RXM S $P(PSORLST,",",J)=""
- ;
- BAD I PSORLST D I 'Y K Y G PSORXEDT
- .W !?15,"=> "_PSORLST
- .K DIR,DIRUT S DIR(0)="Y",DIR("A")="Is this OKAY ",DIR("B")="Yes"
- .D ^DIR K DIR
- .I 'Y!$D(DIRUT) K X,PSORLST,BAD
- K BAD I 'PSORLST K PSORLST G PSORXEDT
- F I=1:1:$L(PSORLST,",") S RXM=$P(PSORLST,",",I) S GOOD=$D(^PSRX("B",RXM)) D
- .I 'GOOD W !!?5,"Couldn't Find RX # "_RXM H 3 Q
- .S RXN=$O(^PSRX("B",RXM,0)) D I $P(^PSRX(RXN,"STA"),"^")=13 W !!?5,"Rx # "_RXM_" is marked for Deletion." H 3 Q
- ..I $G(RXN),$P($G(^PS(55,+$P($G(^PSRX(RXN,0)),"^",2),0)),"^",6)'=2 S PSOLOUD=1 D EN^PSOHLUP(+$P($G(^PSRX(RXN,0)),"^",2)) K PSOLOUD
- .D LIST K GOOD
- K GOOD,END
- ;
- EPH ; - Entry for Epharmacy Rx Edit (PSOREJP1)
- F PSOT1=1:1 Q:'$D(PSOLIST(PSOT1)) F PSOLST2=1:1:$L(PSOLIST(PSOT1),",") S ORN=$P(PSOLIST(PSOT1),",",PSOLST2) D:+ORN PT
- ;
- ; If variable PSOREJCT is set, the EPH entry point was called by
- ; EDT^PSOREJP1, which is invoked by the ED Edit Rx Action on the
- ; ePharmacy Reject Info Screen. If set, PSOREJCT will be Rx IEN ^ Fill.
- ; If the Rx is not released, and the Status is not Suspended, and the
- ; PSORX("NOLABEL") flag is not set, then add this Rx to the PSORX("PSOL")
- ; array. The ED Edit Rx Action sends only one RX, so add as entry 1.
- I $G(PSOREJCT),'$$RXRLDT^PSOBPSUT(+PSOREJCT,$P(PSOREJCT,U,2)),$$GET1^DIQ(52,+PSOREJCT_",",100,"I")'=5,'$G(PSORX("NOLABEL")) S PSORX("PSOL",1)=+PSOREJCT
- ;
- ;call to add bingo board data to file 52.11
- K POP,PSOLIST,TM,TM1 G:'$O(PSORX("PSOL",0)) NX
- D:$G(PSORX("PSOL",1))]"" ^PSORXL K PSORX G:$G(NOBG) NX
- ;
- PRF G:'$P(PSOPAR,"^",8)!($G(NOPP)="H")!($G(NOPP)="S")!('$D(^TMP("PSOBEDT",$J))) BBG
- I $O(^TMP("PSOBEDT",$J,0)),$P(PSOPAR,"^",8) S PSOFROM="NEW",PSOION=ION K RXRS
- G:$D(PSOPROP)&($G(PSOPROP)'=ION) QUP
- I '$D(PSOPROP)!($G(PSOPROP)=ION) D G:$G(POP)!($E(IOST)["C")!(PSOION=ION) BBG
- .S PSOION=ION W !,"Profiles must be sent to Printer !!",! K IOP,%ZIS,IO("Q"),POP
- .S %ZIS="MNQ",%ZIS("A")="Select Profile Device: " D ^%ZIS K %ZIS("A")
- .Q:$G(POP)!($E(IOST)["C")!(PSOION=ION) S PSOPROP=ION
- ;
- QUP S X1=DT,X2=-120 D C^%DTC S PSODTCUT=X,HOLDRPAS=$G(PSOPRPAS),PSOPRPAS=$P(PSOPAR,"^",13)
- F DFN=0:0 S DFN=$O(^TMP("PSOBEDT",$J,DFN)) Q:'DFN S PPL=^TMP("PSOBEDT",$J,DFN,0) D
- .S ZTRTN="DQ^PSOPRF",ZTIO=PSOPROP,ZTDESC="Outpatient Pharmacy Patient Profiles",ZTDTH=$H
- .F G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL" S:$D(@G) ZTSAVE(G)=""
- .D ^%ZTLOAD
- W:$D(ZTSK) !,"PROFILE(S) QUEUED to PRINT",!! K G,ZTSK D ^%ZISC
- S PSOPRPAS=$G(HOLDRPAS) K:PSOPRPAS']"" PSOPRPAS K HOLDRPAS
- ;
- BBG K DFN F PSODFN=0:0 S PSODFN=$O(^TMP("PSOBEDT",$J,PSODFN)) Q:'PSODFN I $G(^TMP("PSOBEDT",$J,PSODFN,1)),$D(DISGROUP) S TM=$P($G(^TMP("PSOBB",$J)),"^"),TM1=$P($G(^($J)),"^",2),PPL=^TMP("PSOBEDT",$J,PSODFN,0) D ^PSOBING1
- ;
- NX ;
- K %X,%Y,ACTREF,ACTREN,D,D0,DAT,DFN,DIC,DIQ,DQ,DRG,END,FDR,PSOBEDT,TM,TM1,PSOT1,PSOLST2,NOBG,BBFLG,BINGCRT,BINGRTE,C,CC,CMOP,COM,CT,D1,DI,DREN,BBRX,PSOFROM,POP,PSORX("QFLG"),IT,PSOERR,PSOBCK,PSOBM,PPL
- K ^TMP("PSOBEDT",$J),^TMP("PSOBB",$J),ZTSK,NOPP,VALMSG,VALMBCK D EOJ
- END Q
- ;---------------------------------------------------------
- PT ;
- N PSOTXEDT,PSOTPEXT S PSOTXEDT=$P($G(^PSRX(ORN,0)),"^",2) I PSOTXEDT I $D(^PS(52.91,PSOTXEDT,0)) I '$P(^PS(52.91,PSOTXEDT,0),"^",3)!($P(^(0),"^",3)>DT) D PDIR^PSOTPCAN(PSOTXEDT) I $G(PSOTPEXT) K PSOTPEXT,PSOTXEDT D EOJ Q
- K PSOTXEDT,PSOTPEXT
- D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1
- S $P(PSOLST(ORN),"^",2)=ORN,(PSOBEDT)=1
- S (DFN,PSODFN)=+$P(^PSRX(ORN,0),"^",2),PSORX("NAME")=$P(^DPT(DFN,0),"^") I PSODFN'=$G(PSOODOSP) K PSORX("DOSING OFF") S PSOODOSP=PSODFN
- D ICN^PSODPT(DFN)
- S RX0=^PSRX(ORN,0),RX2=$G(^(2)),RX3=$G(^(3))
- N PSOCHK S PSOCHK=$$CHK^PSODPT(PSODFN,1,1) ;*422
- I PSOCHK=-1 D EOJ Q ;*422
- D:$G(DUZ("AG"))="V" COPAY^PSOPTPST ; Deals with copay
- K ^TMP("PSOHDR",$J),^TMP("PSOPI",$J) D ^VADPT,ADD^VADPT
- S ^TMP("PSOHDR",$J,1,0)=VADM(1),^TMP("PSOHDR",$J,2,0)=$P(VADM(2),"^",2)
- S ^TMP("PSOHDR",$J,3,0)=$P(VADM(3),"^",2)
- S ^TMP("PSOHDR",$J,4,0)=VADM(4),^TMP("PSOHDR",$J,5,0)=$P(VADM(5),"^",2)
- S POERR=1 D RE^PSODEM K POERR,VALMBCK
- S ^TMP("PSOHDR",$J,6,0)=$S($P(WT,"^",8):$P(WT,"^",9)_" ("_$P(WT,"^")_")",1:"_______ (______)")
- S ^TMP("PSOHDR",$J,7,0)=$S($P(HT,"^",8):$P(HT,"^",9)_" ("_$P(HT,"^")_")",1:"_______ (______)") K VM,WT,HT S PSOHD=7
- S ^TMP("PSOHDR",$J,9,0)="",^TMP("PSOHDR",$J,10,0)=""
- S GMRA="0^0^111" D ^GMRADPT S ^TMP("PSOHDR",$J,8,0)=+$G(GMRAL)
- ;
- ; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
- S PSOBSA=$$BSA^PSSDSAPI(DFN),PSOBSA=$P(PSOBSA,"^",3),PSOBSA=$S(PSOBSA'>0:"_______",1:$J(PSOBSA,4,2)) S ^TMP("PSOHDR",$J,12,0)=PSOBSA
- S RSLT=$$CRCL^PSOORUT2(DFN)
- ; Display format of CrCL and Creatinine results updated - PSO*7.0*556
- I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
- I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
- I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
- I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_"(est.)"_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
- S ^TMP("PSOHDR",$J,13,0)=$G(ZDSPL)
- K PSOBSA,RSLT,ZDSPL
- S ^TMP("PSOHDR",$J,14,0)=$$POSTSHRT^WVRPCOR(PSODFN)
- ;
- D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2) S ^TMP("PSOBB",$J)=TM_"^"_TM1
- S PSOLOUD=1 D:$P($G(^PS(55,PSODFN,0)),"^",6)'=2 EN^PSOHLUP(PSODFN) K PSOLOUD
- S PSOX=$G(^PS(55,PSODFN,"PS")) I PSOX]"" S PSORX("PATIENT STATUS")=$P($G(^PS(53,PSOX,0)),"^")
- D CLEAR^VALM1
- S STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^^EXPIRED^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
- S $P(PSOLST(ORN),"^",3)=$P(STA,"^",$P(^PSRX(ORN,"STA"),"^")+1),PSLST=ORN,ORD=1
- D ACT^PSOORNE2
- ;
- EOJ ;
- K INS1,HDR,IK,INDT,LOG,NODE,ORN,P1,PSI,PSL,PSOLION,PSNP,PSOACT,PSOBM,PSOCLC,PSOCNT,PSODD,PSODFN,PSOHD,PSOJ,PSOLST,PSOOI,PSOPF,PSLST
- K PSOIBQS,PSORLST,PSOSD,PSOSIG,PSPRXN,PSORX0,PSORX1,PTST,REFL,RF,RFD,RIFN,RLD,RPH,RTS,RX0,RX1,RX2,RX3,RXM,RXOR,SIG,SIGOK
- D KVA^VADPT K SLPPL,ST,STA,^TMP("PS",$J),PSOQFLG,PSORXED,PSOEDIT,DIR,DIRUT,DUOUT,DTOUT,PSOLOUD,GMRAL,GG,FEV,ACNT
- D FULL^VALM1 K ^TMP("PSOAL",$J),^TMP("PSOAO",$J),^TMP("PSOSF",$J),^TMP("PSOPF",$J),^TMP("PSOPI",$J),^TMP("PSOPO",$J),^TMP("PSOHDR",$J),PAT
- K JJ,K,MM,PSDAYS,PSOAC,PSOAL,PSOCOU,PSOCOUU,PSONEW,PSODRUG,PSONOOR,PSRX0,QTY,REA,RFCNT,RFDT,RXDA,RXFL,RXREF,SUB,X,Z,ZII,PSOMAILX
- K ACOM,CRIT,DA,DDH,DGI,DGS,PSONEW3,SER,SERS,ZONE,RN,RXN,PSOX,PSOERR,ORD,PSOBCK,PSOBILL,SURX,PSORX("QFLG"),PSORX("FN"),CLOZPAT
- Q
- ;
- LIST ;
- I $G(^PSRX(RXN,0))']"" W !,$C(7),"Rx data is not on file !",! G LISTX
- I $P(^PSRX(RXN,0),"^",15)=13 S PSVD=1 W !,$C(7),"Rx # "_RXM_" has been deleted."
- S RXN1=RXN,RXM1=RXM D:'$G(PSVD) LST1 W "." S RXN=RXN1,RXM=RXM1 K RXN1,RXM1
- F S RXN=$O(^PSRX("B",RXM,RXN)) Q:'RXN D
- .I $G(^PSRX(RXN,0))']"" Q
- .I $P(^PSRX(RXN,0),"^",15)=13 Q
- .D LST1
- K RXN1 G LISTX
- Q
- ;
- LST1 I $G(PSOLIST(1))']"" S PSOLIST(1)=RXN_"," G LISTX
- F PSOX1=0:0 S PSOX1=$O(PSOLIST(PSOX1)) Q:'PSOX1 S PSOX2=PSOX1
- I $L(PSOLIST(PSOX2))+$L(RXN)<220 S:RXN_","'[PSOLIST(PSOX2) PSOLIST(PSOX2)=PSOLIST(PSOX2)_RXN_","
- E S:RXN_","'[PSOLIST(PSOX2+1) PSOLIST(PSOX2+1)=RXN_","
- ;
- LISTX K PSOX1,PSOX2,RXN,PSVD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSORXEDT 8547 printed Jan 18, 2025@03:35:37 Page 2
- PSORXEDT ;BIR/SAB - Edit RX Routine ;Jan 05, 2021@12:04
- +1 ;;7.0;OUTPATIENT PHARMACY;**21,23,44,71,146,185,148,253,390,372,416,313,427,422,402,500,482,556,622,753**;DEC 1997;Build 53
- +2 ;External Reference to ^PS(55 supported by DBIA 2228
- +3 ;External reference to $$BSA^PSSDSAPI supported by DBIA 5425
- +4 if '$DATA(PSOPAR)
- DO ^PSOLSET
- IF '$DATA(PSOPAR)
- GOTO EOJ
- QUIT
- +5 KILL PSODRUG,PSOLIST,DIR,DIRUT,DUOUT,X,Y,PSOFROM,^TMP("PSOBEDT",$JOB),NOPP,CLOZPST,PSOTITRX,PSOMTFLG
- +6 NEW PSOODOSP
- +7 WRITE !!
- SET DIR(0)="FAO^1:245"
- SET DIR("A")="Edit Rx(s) => "
- SET DIR("?",1)="Enter Rx Number or A List of numbers Separated"
- SET DIR("?")="by Commas, e.g. 1234A,345,937002Q."
- +8 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO EOJ
- +9 SET END=$LENGTH(X,",")
- SET BAD=0
- +10 FOR I=1:1:END
- SET RXM=$PIECE(X,",",I)
- IF +RXM
- FOR J=I+1:1:END
- SET DUP=$PIECE(X,",",J)
- IF DUP=RXM
- SET $PIECE(X,",",J)=""
- WRITE !?5,$CHAR(7),"Duplicate Rx # "_RXM_" was found in your list, ignoring it!",!
- SET BAD=1
- +11 SET PSORLST=$PIECE(X,",")
- FOR I=2:1:END
- SET RXM=$PIECE(X,",",I)
- if RXM'?1.N.A
- SET BAD=1
- IF RXM?1.N.A
- SET PSORLST=PSORLST_","_RXM
- +12 FOR I=1:1:$LENGTH(PSORLST)
- SET RXM=$PIECE(PSORLST,",",I)
- IF +RXM
- FOR J=I+1:1:END
- SET DUP=$PIECE(PSORLST,",",J)
- IF DUP=RXM
- SET $PIECE(PSORLST,",",J)=""
- +13 ;
- BAD IF PSORLST
- Begin DoDot:1
- +1 WRITE !?15,"=> "_PSORLST
- +2 KILL DIR,DIRUT
- SET DIR(0)="Y"
- SET DIR("A")="Is this OKAY "
- SET DIR("B")="Yes"
- +3 DO ^DIR
- KILL DIR
- +4 IF 'Y!$DATA(DIRUT)
- KILL X,PSORLST,BAD
- End DoDot:1
- IF 'Y
- KILL Y
- GOTO PSORXEDT
- +5 KILL BAD
- IF 'PSORLST
- KILL PSORLST
- GOTO PSORXEDT
- +6 FOR I=1:1:$LENGTH(PSORLST,",")
- SET RXM=$PIECE(PSORLST,",",I)
- SET GOOD=$DATA(^PSRX("B",RXM))
- Begin DoDot:1
- +7 IF 'GOOD
- WRITE !!?5,"Couldn't Find RX # "_RXM
- HANG 3
- QUIT
- +8 SET RXN=$ORDER(^PSRX("B",RXM,0))
- Begin DoDot:2
- +9 IF $GET(RXN)
- IF $PIECE($GET(^PS(55,+$PIECE($GET(^PSRX(RXN,0)),"^",2),0)),"^",6)'=2
- SET PSOLOUD=1
- DO EN^PSOHLUP(+$PIECE($GET(^PSRX(RXN,0)),"^",2))
- KILL PSOLOUD
- End DoDot:2
- IF $PIECE(^PSRX(RXN,"STA"),"^")=13
- WRITE !!?5,"Rx # "_RXM_" is marked for Deletion."
- HANG 3
- QUIT
- +10 DO LIST
- KILL GOOD
- End DoDot:1
- +11 KILL GOOD,END
- +12 ;
- EPH ; - Entry for Epharmacy Rx Edit (PSOREJP1)
- +1 FOR PSOT1=1:1
- if '$DATA(PSOLIST(PSOT1))
- QUIT
- FOR PSOLST2=1:1:$LENGTH(PSOLIST(PSOT1),",")
- SET ORN=$PIECE(PSOLIST(PSOT1),",",PSOLST2)
- if +ORN
- DO PT
- +2 ;
- +3 ; If variable PSOREJCT is set, the EPH entry point was called by
- +4 ; EDT^PSOREJP1, which is invoked by the ED Edit Rx Action on the
- +5 ; ePharmacy Reject Info Screen. If set, PSOREJCT will be Rx IEN ^ Fill.
- +6 ; If the Rx is not released, and the Status is not Suspended, and the
- +7 ; PSORX("NOLABEL") flag is not set, then add this Rx to the PSORX("PSOL")
- +8 ; array. The ED Edit Rx Action sends only one RX, so add as entry 1.
- +9 IF $GET(PSOREJCT)
- IF '$$RXRLDT^PSOBPSUT(+PSOREJCT,$PIECE(PSOREJCT,U,2))
- IF $$GET1^DIQ(52,+PSOREJCT_",",100,"I")'=5
- IF '$GET(PSORX("NOLABEL"))
- SET PSORX("PSOL",1)=+PSOREJCT
- +10 ;
- +11 ;call to add bingo board data to file 52.11
- +12 KILL POP,PSOLIST,TM,TM1
- if '$ORDER(PSORX("PSOL",0))
- GOTO NX
- +13 if $GET(PSORX("PSOL",1))]""
- DO ^PSORXL
- KILL PSORX
- if $GET(NOBG)
- GOTO NX
- +14 ;
- PRF if '$PIECE(PSOPAR,"^",8)!($GET(NOPP)="H")!($GET(NOPP)="S")!('$DATA(^TMP("PSOBEDT",$JOB)))
- GOTO BBG
- +1 IF $ORDER(^TMP("PSOBEDT",$JOB,0))
- IF $PIECE(PSOPAR,"^",8)
- SET PSOFROM="NEW"
- SET PSOION=ION
- KILL RXRS
- +2 if $DATA(PSOPROP)&($GET(PSOPROP)'=ION)
- GOTO QUP
- +3 IF '$DATA(PSOPROP)!($GET(PSOPROP)=ION)
- Begin DoDot:1
- +4 SET PSOION=ION
- WRITE !,"Profiles must be sent to Printer !!",!
- KILL IOP,%ZIS,IO("Q"),POP
- +5 SET %ZIS="MNQ"
- SET %ZIS("A")="Select Profile Device: "
- DO ^%ZIS
- KILL %ZIS("A")
- +6 if $GET(POP)!($EXTRACT(IOST)["C")!(PSOION=ION)
- QUIT
- SET PSOPROP=ION
- End DoDot:1
- if $GET(POP)!($EXTRACT(IOST)["C")!(PSOION=ION)
- GOTO BBG
- +7 ;
- QUP SET X1=DT
- SET X2=-120
- DO C^%DTC
- SET PSODTCUT=X
- SET HOLDRPAS=$GET(PSOPRPAS)
- SET PSOPRPAS=$PIECE(PSOPAR,"^",13)
- +1 FOR DFN=0:0
- SET DFN=$ORDER(^TMP("PSOBEDT",$JOB,DFN))
- if 'DFN
- QUIT
- SET PPL=^TMP("PSOBEDT",$JOB,DFN,0)
- Begin DoDot:1
- +2 SET ZTRTN="DQ^PSOPRF"
- SET ZTIO=PSOPROP
- SET ZTDESC="Outpatient Pharmacy Patient Profiles"
- SET ZTDTH=$HOROLOG
- +3 FOR G="PSOPAR","PSODTCUT","PSOPRPAS","DFN","PSOSITE","NEW1","NEW11","PSOBMST","PFIO","PPL"
- if $DATA(@G)
- SET ZTSAVE(G)=""
- +4 DO ^%ZTLOAD
- End DoDot:1
- +5 if $DATA(ZTSK)
- WRITE !,"PROFILE(S) QUEUED to PRINT",!!
- KILL G,ZTSK
- DO ^%ZISC
- +6 SET PSOPRPAS=$GET(HOLDRPAS)
- if PSOPRPAS']""
- KILL PSOPRPAS
- KILL HOLDRPAS
- +7 ;
- BBG KILL DFN
- FOR PSODFN=0:0
- SET PSODFN=$ORDER(^TMP("PSOBEDT",$JOB,PSODFN))
- if 'PSODFN
- QUIT
- IF $GET(^TMP("PSOBEDT",$JOB,PSODFN,1))
- IF $DATA(DISGROUP)
- SET TM=$PIECE($GET(^TMP("PSOBB",$JOB)),"^")
- SET TM1=$PIECE($GET(^($JOB)),"^",2)
- SET PPL=^TMP("PSOBEDT",$JOB,PSODFN,0)
- DO ^PSOBING1
- +1 ;
- NX ;
- +1 KILL %X,%Y,ACTREF,ACTREN,D,D0,DAT,DFN,DIC,DIQ,DQ,DRG,END,FDR,PSOBEDT,TM,TM1,PSOT1,PSOLST2,NOBG,BBFLG,BINGCRT,BINGRTE,C,CC,CMOP,COM,CT,D1,DI,DREN,BBRX,PSOFROM,POP,PSORX("QFLG"),IT,PSOERR,PSOBCK,PSOBM,PPL
- +2 KILL ^TMP("PSOBEDT",$JOB),^TMP("PSOBB",$JOB),ZTSK,NOPP,VALMSG,VALMBCK
- DO EOJ
- END QUIT
- +1 ;---------------------------------------------------------
- PT ;
- +1 NEW PSOTXEDT,PSOTPEXT
- SET PSOTXEDT=$PIECE($GET(^PSRX(ORN,0)),"^",2)
- IF PSOTXEDT
- IF $DATA(^PS(52.91,PSOTXEDT,0))
- IF '$PIECE(^PS(52.91,PSOTXEDT,0),"^",3)!($PIECE(^(0),"^",3)>DT)
- DO PDIR^PSOTPCAN(PSOTXEDT)
- IF $GET(PSOTPEXT)
- KILL PSOTPEXT,PSOTXEDT
- DO EOJ
- QUIT
- +2 KILL PSOTXEDT,PSOTPEXT
- +3 DO NOW^%DTC
- SET TM=$EXTRACT(%,1,12)
- SET TM1=$PIECE(TM,".",2)
- SET ^TMP("PSOBB",$JOB)=TM_"^"_TM1
- +4 SET $PIECE(PSOLST(ORN),"^",2)=ORN
- SET (PSOBEDT)=1
- +5 SET (DFN,PSODFN)=+$PIECE(^PSRX(ORN,0),"^",2)
- SET PSORX("NAME")=$PIECE(^DPT(DFN,0),"^")
- IF PSODFN'=$GET(PSOODOSP)
- KILL PSORX("DOSING OFF")
- SET PSOODOSP=PSODFN
- +6 DO ICN^PSODPT(DFN)
- +7 SET RX0=^PSRX(ORN,0)
- SET RX2=$GET(^(2))
- SET RX3=$GET(^(3))
- +8 ;*422
- NEW PSOCHK
- SET PSOCHK=$$CHK^PSODPT(PSODFN,1,1)
- +9 ;*422
- IF PSOCHK=-1
- DO EOJ
- QUIT
- +10 ; Deals with copay
- if $GET(DUZ("AG"))="V"
- DO COPAY^PSOPTPST
- +11 KILL ^TMP("PSOHDR",$JOB),^TMP("PSOPI",$JOB)
- DO ^VADPT
- DO ADD^VADPT
- +12 SET ^TMP("PSOHDR",$JOB,1,0)=VADM(1)
- SET ^TMP("PSOHDR",$JOB,2,0)=$PIECE(VADM(2),"^",2)
- +13 SET ^TMP("PSOHDR",$JOB,3,0)=$PIECE(VADM(3),"^",2)
- +14 SET ^TMP("PSOHDR",$JOB,4,0)=VADM(4)
- SET ^TMP("PSOHDR",$JOB,5,0)=$PIECE(VADM(5),"^",2)
- +15 SET POERR=1
- DO RE^PSODEM
- KILL POERR,VALMBCK
- +16 SET ^TMP("PSOHDR",$JOB,6,0)=$SELECT($PIECE(WT,"^",8):$PIECE(WT,"^",9)_" ("_$PIECE(WT,"^")_")",1:"_______ (______)")
- +17 SET ^TMP("PSOHDR",$JOB,7,0)=$SELECT($PIECE(HT,"^",8):$PIECE(HT,"^",9)_" ("_$PIECE(HT,"^")_")",1:"_______ (______)")
- KILL VM,WT,HT
- SET PSOHD=7
- +18 SET ^TMP("PSOHDR",$JOB,9,0)=""
- SET ^TMP("PSOHDR",$JOB,10,0)=""
- +19 SET GMRA="0^0^111"
- DO ^GMRADPT
- SET ^TMP("PSOHDR",$JOB,8,0)=+$GET(GMRAL)
- +20 ;
- +21 ; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
- +22 SET PSOBSA=$$BSA^PSSDSAPI(DFN)
- SET PSOBSA=$PIECE(PSOBSA,"^",3)
- SET PSOBSA=$SELECT(PSOBSA'>0:"_______",1:$JUSTIFY(PSOBSA,4,2))
- SET ^TMP("PSOHDR",$JOB,12,0)=PSOBSA
- +23 SET RSLT=$$CRCL^PSOORUT2(DFN)
- +24 ; Display format of CrCL and Creatinine results updated - PSO*7.0*556
- +25 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
- +26 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
- +27 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
- +28 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
- SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_"(est.)"_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
- +29 SET ^TMP("PSOHDR",$JOB,13,0)=$GET(ZDSPL)
- +30 KILL PSOBSA,RSLT,ZDSPL
- +31 SET ^TMP("PSOHDR",$JOB,14,0)=$$POSTSHRT^WVRPCOR(PSODFN)
- +32 ;
- +33 DO NOW^%DTC
- SET TM=$EXTRACT(%,1,12)
- SET TM1=$PIECE(TM,".",2)
- SET ^TMP("PSOBB",$JOB)=TM_"^"_TM1
- +34 SET PSOLOUD=1
- if $PIECE($GET(^PS(55,PSODFN,0)),"^",6)'=2
- DO EN^PSOHLUP(PSODFN)
- KILL PSOLOUD
- +35 SET PSOX=$GET(^PS(55,PSODFN,"PS"))
- IF PSOX]""
- SET PSORX("PATIENT STATUS")=$PIECE($GET(^PS(53,PSOX,0)),"^")
- +36 DO CLEAR^VALM1
- +37 SET STA="ACTIVE^NON-VERIFIED^REFILL^HOLD^NON-VERIFIED^SUSPENDED^^^^^^EXPIRED^DISCONTINUED^^DISCONTINUED^DISCONTINUED^HOLD"
- +38 SET $PIECE(PSOLST(ORN),"^",3)=$PIECE(STA,"^",$PIECE(^PSRX(ORN,"STA"),"^")+1)
- SET PSLST=ORN
- SET ORD=1
- +39 DO ACT^PSOORNE2
- +40 ;
- EOJ ;
- +1 KILL INS1,HDR,IK,INDT,LOG,NODE,ORN,P1,PSI,PSL,PSOLION,PSNP,PSOACT,PSOBM,PSOCLC,PSOCNT,PSODD,PSODFN,PSOHD,PSOJ,PSOLST,PSOOI,PSOPF,PSLST
- +2 KILL PSOIBQS,PSORLST,PSOSD,PSOSIG,PSPRXN,PSORX0,PSORX1,PTST,REFL,RF,RFD,RIFN,RLD,RPH,RTS,RX0,RX1,RX2,RX3,RXM,RXOR,SIG,SIGOK
- +3 DO KVA^VADPT
- KILL SLPPL,ST,STA,^TMP("PS",$JOB),PSOQFLG,PSORXED,PSOEDIT,DIR,DIRUT,DUOUT,DTOUT,PSOLOUD,GMRAL,GG,FEV,ACNT
- +4 DO FULL^VALM1
- KILL ^TMP("PSOAL",$JOB),^TMP("PSOAO",$JOB),^TMP("PSOSF",$JOB),^TMP("PSOPF",$JOB),^TMP("PSOPI",$JOB),^TMP("PSOPO",$JOB),^TMP("PSOHDR",$JOB),PAT
- +5 KILL JJ,K,MM,PSDAYS,PSOAC,PSOAL,PSOCOU,PSOCOUU,PSONEW,PSODRUG,PSONOOR,PSRX0,QTY,REA,RFCNT,RFDT,RXDA,RXFL,RXREF,SUB,X,Z,ZII,PSOMAILX
- +6 KILL ACOM,CRIT,DA,DDH,DGI,DGS,PSONEW3,SER,SERS,ZONE,RN,RXN,PSOX,PSOERR,ORD,PSOBCK,PSOBILL,SURX,PSORX("QFLG"),PSORX("FN"),CLOZPAT
- +7 QUIT
- +8 ;
- LIST ;
- +1 IF $GET(^PSRX(RXN,0))']""
- WRITE !,$CHAR(7),"Rx data is not on file !",!
- GOTO LISTX
- +2 IF $PIECE(^PSRX(RXN,0),"^",15)=13
- SET PSVD=1
- WRITE !,$CHAR(7),"Rx # "_RXM_" has been deleted."
- +3 SET RXN1=RXN
- SET RXM1=RXM
- if '$GET(PSVD)
- DO LST1
- WRITE "."
- SET RXN=RXN1
- SET RXM=RXM1
- KILL RXN1,RXM1
- +4 FOR
- SET RXN=$ORDER(^PSRX("B",RXM,RXN))
- if 'RXN
- QUIT
- Begin DoDot:1
- +5 IF $GET(^PSRX(RXN,0))']""
- QUIT
- +6 IF $PIECE(^PSRX(RXN,0),"^",15)=13
- QUIT
- +7 DO LST1
- End DoDot:1
- +8 KILL RXN1
- GOTO LISTX
- +9 QUIT
- +10 ;
- LST1 IF $GET(PSOLIST(1))']""
- SET PSOLIST(1)=RXN_","
- GOTO LISTX
- +1 FOR PSOX1=0:0
- SET PSOX1=$ORDER(PSOLIST(PSOX1))
- if 'PSOX1
- QUIT
- SET PSOX2=PSOX1
- +2 IF $LENGTH(PSOLIST(PSOX2))+$LENGTH(RXN)<220
- if RXN_","'[PSOLIST(PSOX2)
- SET PSOLIST(PSOX2)=PSOLIST(PSOX2)_RXN_","
- +3 IF '$TEST
- if RXN_","'[PSOLIST(PSOX2+1)
- SET PSOLIST(PSOX2+1)=RXN_","
- +4 ;
- LISTX KILL PSOX1,PSOX2,RXN,PSVD
- +1 QUIT