PSOERXU5 ;ALB/BWF - eRx utilities ; 4/9/2018 10:55am
;;7.0;OUTPATIENT PHARMACY;**508,581,651**;DEC 1997;Build 30
;
Q
CANREQ(ERXIEN,LINE,PMODE) ;
N REQIEN,REQDTTM,COMM,HUBID,CANSTAT,DNB,RESTYPE,COMM,COMMARY,COMMBY,COMMDTTM,CTXT,I,REQBY
; - the next line of code will actually reference the related message for retrieval of the cancel request information
; - check that this is correct and test.
S REQIEN=ERXIEN
I $$GET1^DIQ(52.49,ERXIEN,.08,"I")="CN" S REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
I '$$FINDNRX^PSOERXU6(REQIEN) S DNB=1
S HUBID=$$GET1^DIQ(52.49,REQIEN,.01,"E")
S REQBY=$$GET1^DIQ(52.49,REQIEN,2.1,"E")
S REQDTTM=$$GET1^DIQ(52.49,REQIEN,.03,"E")
;S DNB=$$GET1^DIQ(52.49,REQIEN,80.5,"I")
S COMM=$$GET1^DIQ(52.49,REQIEN,50,"E")
S RESTYPE=$$GET1^DIQ(52.49,REQIEN,52.1,"E")
S CANSTAT=$$GET1^DIQ(52.49,REQIEN,1,"I")
S CANSTAT=$$GET1^DIQ(52.45,CANSTAT,.02,"E")
S LINE=LINE+1 D SET^VALM10(LINE,"")
S LINE=LINE+1 D SET^VALM10(LINE,"************************CANCEL REQUEST INFORMATION**************************")
I '$G(PMODE) S LINE=LINE+1 D SET^VALM10(LINE,RESTYPE),CNTRL^VALM10(LINE,1,$L(RESTYPE),IORVON,IORVOFF)
S LINE=LINE+1 D SET^VALM10(LINE,"Request Status: "_CANSTAT)
I $L(RESTYPE) S LINE=LINE+1 D SET^VALM10(LINE,"Request/Response Type: "_RESTYPE)
S LINE=LINE+1 D SET^VALM10(LINE,"Requested By: "_REQBY)
S LINE=LINE+1 D SET^VALM10(LINE,"Request Date/Time: "_REQDTTM)
I $G(DNB) S LINE=LINE+1 D SET^VALM10(LINE,"Original eRx not found in Hub and/or in Vista.")
S LINE=LINE+1 D SET^VALM10(LINE,"")
S COMM=$$GET1^DIQ(52.49,REQIEN,50,"E")
S COMM="Request Comments: "_COMM
D TXT2ARY^PSOERXD1(.COMMARY,COMM," ",80)
S I=0 F S I=$O(COMMARY(I)) Q:'I D
.S CTXT=$G(COMMARY(I))
.S LINE=LINE+1 D SET^VALM10(LINE,CTXT)
S COMMBY=$$GET1^DIQ(52.49,REQIEN,50.1,"E")
S COMMDTTM=$$GET1^DIQ(52.49,REQIEN,50.2,"E")
S LINE=LINE+1 D SET^VALM10(LINE,"Comments By: "_COMMBY)
S LINE=LINE+1 D SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM)
S LINE=LINE+1 D SET^VALM10(LINE,"")
Q
CANRES(ERXIEN,LINE,PMODE) ;
N MTYPE,IENS,RESIEN,REQIEN,HUBID,RESVAL,RESCODE,RESNOTE,RESDTTM,CANSTAT,RESBY,COMM,COMMARY,COMMBY,COMMDTTM,ERXDAT
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
I MTYPE="CN" S RESIEN=ERXIEN,REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
I MTYPE="CA" S REQIEN=ERXIEN,RESIEN=$$GETRESP^PSOERXU2(ERXIEN)
I MTYPE="IE" S RESIEN=$$RESOLV^PSOERXU2(ERXIEN)
S REQIEN=$$RESOLV^PSOERXU2(RESIEN)
Q:'RESIEN
S IENS=RESIEN_","
D GETS^DIQ(52.49,RESIEN,".01;.03;1;51.1;52.1;52.2;52.3","IE","ERXDAT")
S HUBID=$G(ERXDAT(52.49,IENS,.01,"E"))
S RESVAL=$G(ERXDAT(52.49,IENS,52.1,"E"))
S RESCODE=$G(ERXDAT(52.49,IENS,52.1,"I"))
S RESNOTE=$G(ERXDAT(52.49,IENS,52.2,"E"))
S RESDTTM=$G(ERXDAT(52.49,IENS,.03,"E"))
S CANSTAT=$G(ERXDAT(52.49,IENS,.03,"I"))
S CANSTAT=$$GET1^DIQ(52.45,CANSTAT,.02,"E")
S RESBY=$G(ERXDAT(52.49,IENS,51.1,"E"))
S LINE=LINE+1 D SET^VALM10(LINE,"")
S LINE=LINE+1 D SET^VALM10(LINE,"************************CANCEL RESPONSE INFORMATION**************************")
I '$G(PMODE) S LINE=LINE+1 D SET^VALM10(LINE,RESVAL),CNTRL^VALM10(LINE,1,$L(RESVAL),IORVON,IORVOFF)
S LINE=LINE+1 D SET^VALM10(LINE,"Response Status: "_CANSTAT)
I $L(RESVAL) S LINE=LINE+1 D SET^VALM10(LINE,"Request/Response Type: "_RESVAL)
S LINE=LINE+1 D SET^VALM10(LINE,"Response: "_RESNOTE)
S LINE=LINE+1 D SET^VALM10(LINE,"Response by: "_RESBY)
S LINE=LINE+1 D SET^VALM10(LINE,"Response Date/Time: "_RESDTTM)
S LINE=LINE+1 D SET^VALM10(LINE,"")
S COMM=$$GET1^DIQ(52.49,RESIEN,50,"E")
S COMM="Response Comments: "_COMM
D TXT2ARY^PSOERXD1(.COMMARY,COMM," ",80)
S I=0 F S I=$O(COMMARY(I)) Q:'I D
.S CTXT=$G(COMMARY(I))
.S LINE=LINE+1 D SET^VALM10(LINE,CTXT)
S COMMBY=$$GET1^DIQ(52.49,RESIEN,50.1,"E")
S COMMDTTM=$$GET1^DIQ(52.49,RESIEN,50.2,"E")
S LINE=LINE+1 D SET^VALM10(LINE,"Comments By: "_COMMBY)
S LINE=LINE+1 D SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM)
S LINE=LINE+1 D SET^VALM10(LINE,"")
Q
GETPAT(ERXIEN) ;
N ERXPAT,MTYPE,REQIEN,NEWRXIEN
S ERXPAT=$$GET1^DIQ(52.49,ERXIEN,.04,"I")
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
I 'ERXPAT,"RR,CA,"[MTYPE D
.S NEWRXIEN=$$RESOLV^PSOERXU2(ERXIEN)
.S ERXPAT=$$GET1^DIQ(52.49,NEWRXIEN,.04,"I")
I 'ERXPAT,"RE,CN,IE,"[MTYPE D
.S REQIEN=$$RESOLV^PSOERXU2(ERXIEN) Q:'REQIEN
.S ERXPAT=$$GET1^DIQ(52.49,REQIEN,.04,"I") I ERXPAT Q
.S NEWRXIEN=$$RESOLV^PSOERXU2(REQIEN)
.S ERXPAT=$$GET1^DIQ(52.49,NEWRXIEN,.04,"I")
Q:'ERXPAT 0
Q ERXPAT
GETPROV(ERXIEN) ;
N ERXPRV,MTYPE,REQIEN,NEWRXIEN
S ERXPRV=$$GET1^DIQ(52.49,ERXIEN,2.1,"I")
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
I 'ERXPRV,"RR,CA,"[MTYPE D
.S NEWRXIEN=$$RESOLV^PSOERXU2(ERXIEN)
.S ERXPRV=$$GET1^DIQ(52.49,NEWRXIEN,2.1,"I")
I 'ERXPRV,"RE,CN"[MTYPE D
.S REQIEN=$$RESOLV^PSOERXU2(ERXIEN) Q:'REQIEN
.S ERXPRV=$$GET1^DIQ(52.49,REQIEN,2.1,"I") I ERXPRV Q
.S NEWRXIEN=$$RESOLV^PSOERXU2(REQIEN)
.S ERXPRV=$$GET1^DIQ(52.49,NEWRXIEN,2.1,"I")
Q:'ERXPRV 0
Q ERXPRV
GETDRUG(ERXIEN) ;
N ERXDRG,MTYPE,REQIEN,NEWRXIEN
S ERXDRG=$$GET1^DIQ(52.49,ERXIEN,3.1,"E")
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
I ERXDRG="","RR,CA,"[MTYPE D
.S NEWRXIEN=$$RESOLV^PSOERXU2(ERXIEN)
.S ERXDRG=$$GET1^DIQ(52.49,NEWRXIEN,3.1,"E")
I 'ERXDRG,"RE,CN"[MTYPE D
.S REQIEN=$$RESOLV^PSOERXU2(ERXIEN) Q:'REQIEN
.S ERXDRG=$$GET1^DIQ(52.49,REQIEN,3.1,"I") I ERXDRG'="" Q
.S NEWRXIEN=$$RESOLV^PSOERXU2(REQIEN)
.S ERXDRG=$$GET1^DIQ(52.49,NEWRXIEN,3.1,"I")
I ERXDRG="" Q ""
Q ERXDRG
CANACK(ERXIEN) ;
N DIR,MTYPE,ERXSTAT,INST,RESP,RESID,Y,PSSRET,DIRUT,DTOUT,RESCHECK,MESREQ,RTMIEN,RTMTYPE
D FULL^VALM1 S VALMBCK="R"
I $D(^XUSEC("PSO ERX VIEW",DUZ)) W !,">>> You do not have privilege to use this option." D DIRE^PSOERXX1 Q
S MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
S RESTYPE=$$GET1^DIQ(52.49,ERXIEN,52.1,"I"),MESREQ=$$GET1^DIQ(52.49,ERXIEN,315.1,"E")
S ERXSTAT=$$GET1^DIQ(52.49,ERXIEN,1,"E")
I ",CAA,CXA,ICA,IEA,IRA,RXA,"[ERXSTAT W !!,"Record already acknowledged!",!,$C(7) D DIRE^PSOERXX1 Q
I RESTYPE="A"!(RESTYPE="AWC"),MESREQ="G"!(MESREQ="T")!(MESREQ="S")!(MESREQ="OS")!(MESREQ="D") S RESCHECK=1
I $G(RESCHECK) W !,"For RxChange Response Approved and Approved with changes types (G/T/S/OS/D)",!,"hidden action ACK is not available." D DIRE^PSOERXX1 Q
I MTYPE="CX",RESTYPE="V" W !,"ACK is not available for RxChange Response - 'Validated' response messages." D DIRE^PSOERXX1 Q
I MTYPE="CX",'$G(RESCHECK) D Q
.W !,"Would you like to acknowledge this record?"
.S DIR(0)="YO",DIR("B")="N" D ^DIR K DIR Q:'Y!($D(DIRUT))!($D(DTOUT))
.I Y=1 D
..D UPDSTAT^PSOERXU1(ERXIEN,"CXA")
;
I MTYPE="RE"!(MTYPE="IE"),'$D(^XUSEC("PSDRPH",DUZ)),'$D(^XUSEC("PSO ERX ADV TECH",DUZ)),'$D(^XUSEC("PSO ERX TECH",DUZ)) D Q
.W !,"You do not have priviledge to use this option." D DIRE^PSOERXX1
I MTYPE="CA"!(MTYPE="CN"),'$D(^XUSEC("PSDRPH",DUZ)),'$D(^XUSEC("PSO ERX ADV TECH",DUZ)) D Q
.W !,"You do not have priviledge to use this option." D DIRE^PSOERXX1
I ",CAO,CAH,CAF,CAP,CAR,CAX,RXD,RRE,RXF,CXV,CXD,CXY,CRE,"'[ERXSTAT W !,"Acknowledge cannot be used on this record status." D DIRE^PSOERXX1 Q
I (ERXSTAT="CAO")!(ERXSTAT="RXD")!(ERXSTAT="RRE")!(ERXSTAT="CRE")!(ERXSTAT="RXF") D Q
.W !,"Would you like to acknowledge this record?"
.S DIR(0)="YO",DIR("B")="N" D ^DIR K DIR Q:'Y!($D(DIRUT))!($D(DTOUT))
.K Y
.S RTMIEN=$$RESOLV^PSOERXU2(ERXIEN),RTMTYPE=$$GET1^DIQ(52.49,RTMIEN,.08,"I")
.I MTYPE="CA" D UPDSTAT^PSOERXU1(ERXIEN,"CAA")
.I MTYPE="RE" D UPDSTAT^PSOERXU1(ERXIEN,"RXA")
.I MTYPE="IE",RTMTYPE="RR" D UPDSTAT^PSOERXU1(ERXIEN,"IRA")
.I MTYPE="IE",RTMTYPE="CR" D UPDSTAT^PSOERXU1(ERXIEN,"ICA")
.I MTYPE="CR" D UPDSTAT^PSOERXU1(ERXIEN,"ICA")
.W !,$S(MTYPE="CA":"Cancel request",MTYPE="RE":"RxRenewal response",1:"Inbound error")," acknowledged." D DIRE^PSOERXX1
.K @VALMAR D INIT^PSOERX1
S INST=$$GET1^DIQ(52.49,ERXIEN,24.1,"I")
W !,"Would you like to send an 'Approved' or 'Denied' response?"
K DIR S DIR(0)="SO^A:APPROVED;D:DENIED"
S DIR("?")="prescription."
S DIR("?",1)="Approved - The user was able to Cancel or Discontinue the original"
S DIR("?",2)="prescription."
S DIR("?",3)=""
S DIR("?",4)="Denied - The user was not able to Cancel or Discontinue the original"
D ^DIR K DIR Q:Y=""!($D(DIRUT))!($D(DTOUT))
I Y="A" S RESP="Rx was never dispensed. Canceled at Pharmacy."
I Y="D" S RESP="Rx Not Canceled - Rx not found in pharmacy system."
I Y="A",MTYPE="CA" S RESP="Rx canceled at Pharmacy."
S RESID=$S(Y="A":3,Y="D":2,1:0)
W !,"Would you like to acknowledge this record?"
S DIR(0)="YO",DIR("B")="N" D ^DIR K DIR Q:'Y!($D(DIRUT))!($D(DTOUT))
D POST^PSOERXO1(ERXIEN,.PSSRET,,,,RESID,INST,RESP)
I $D(PSSRET("errorMessage")) W !!,PSSRET("errorMessage") D DIRE^PSOERXX1 Q
I MTYPE="CA" D UPDSTAT^PSOERXU1(ERXIEN,"CAA")
I MTYPE="RE" D UPDSTAT^PSOERXU1(ERXIEN,"RXA")
I MTYPE="IE" D UPDSTAT^PSOERXU1(ERXIEN,"IRA")
W !,$S(MTYPE="CA":"Cancel request",MTYPE="RE":"RxRenewal response",1:"Inbound error")," acknowledged." D DIRE^PSOERXX1
K @VALMAR D INIT^PSOERX1
Q
LASTSTAT(ERXIEN) ;
N STAT,DONE,CSTAT,LSTAT,RSTAT
S DONE=0,RSTAT=""
S CSTAT=$$GET1^DIQ(52.49,ERXIEN,1,"I")
S STAT=99999 F S STAT=$O(^PS(52.49,ERXIEN,19,STAT),-1) Q:'STAT!(DONE) D
.S LSTAT=$$GET1^DIQ(52.4919,STAT_","_ERXIEN_",",.02,"I")
.I LSTAT=CSTAT Q
.S RSTAT=$$GET1^DIQ(52.45,LSTAT,.01,"E")_" - "_$$GET1^DIQ(52.45,LSTAT,.02,"E"),DONE=1
Q RSTAT
CSCOMM(ERXIEN) ;
N STAT,DONE,SCOMM
S CSTAT=$$GET1^DIQ(52.49,ERXIEN,1,"I")
S STAT=$O(^PS(52.49,ERXIEN,19,999999),-1) I 'STAT Q ""
S SCOMM=$$GET1^DIQ(52.4919,STAT_","_ERXIEN_",",1,"E")
Q SCOMM
COMMVAL(IEN,FILE,SUB,TYPE,EXTFLG) ; IEN, file number, communication subscript, type of communication,
; extension flag (optional)
N CHECK,EXT,VAL,X,SFIEN,TYPEVAL
S SFIEN=0
F S SFIEN=$O(^PS(FILE,IEN,SUB,SFIEN)) Q:'SFIEN!($G(VAL)) D
.S TYPEVAL=$$GET1^DIQ(FILE_SUB,SFIEN_","_IEN_",",.02,"I")
.I TYPEVAL=TYPE D
..S VAL=$$GET1^DIQ(FILE_SUB,SFIEN_","_IEN_",",.03)
..I $G(EXTFLG) D
...S EXT=$$GET1^DIQ(FILE_SUB,SFIEN_","_IEN_",",.04)
...S:EXT]"" VAL=VAL_"X"_EXT
I '$G(VAL) Q ""
Q VAL
EFFDATE(IEN,MIEN) ; if it exists in "other medication date" subfile, return the effective date
I 'MIEN Q ""
N OMDIEN,EFFCHECK,EFFDATE
S OMDIEN=0
F S OMDIEN=$O(^PS(52.49,IEN,311,MIEN,62,OMDIEN)) Q:'OMDIEN!($G(EFFDATE)) D
.S EFFCHECK=$$GET1^DIQ(52.4931162,OMDIEN_","_MIEN_","_IEN_",",.03)
.I $G(EFFCHECK)="EffectiveDate" D
..S EFFDATE=$$GET1^DIQ(52.4931162,OMDIEN_","_MIEN_","_IEN_",",.02,"E") Q
Q $G(EFFDATE)
DIAG2017(PSOIEN,LINE,GL,MIEN) ;
N DIAGIEN,DIAGDAT,DIAGSEQ,PDIAGQ,PDIAGV,SDIAGQ,SDIAGV,DIAGDAT,DIACIC,DRES,SDRES,PDIAGTXT,SDIAGTXT
N SDRESL,SDRESDAT,DRESL,DRESDAT,PDIAGARY,SDIAGARY,PDFRST,SDFRST,PDLOOP,SDLOOP,DIENS,PDESC,SDESC,PDESCARY,SDESCARY
Q:'$G(MIEN)
S DIAGIEN=0 F S DIAGIEN=$O(^PS(52.49,PSOIEN,311,MIEN,3,DIAGIEN)) Q:'DIAGIEN D
.S DIENS=DIAGIEN_","_MIEN_","_PSOIEN_"," K PDIAGARY,SDIAGARY,DIAGDAT
.D GETS^DIQ(52.493113,DIENS,"**","IE","DIAGDAT")
.S DIAGSEQ=$G(DIAGDAT(52.493113,DIENS,.01,"E"))
.S DIACIC=$G(DIAGDAT(52.493113,DIENS,.02,"E"))
.S PDIAGQ=$G(DIAGDAT(52.493113,DIENS,1.2,"E"))
.S PDIAGV=$G(DIAGDAT(52.493113,DIENS,1.1,"E"))
.S PDESC=$G(DIAGDAT(52.493113,DIENS,2,"E")) D TXT2ARY^PSOERXD1(.PDESCARY,"Description: "_PDESC," ",55)
.I PDIAGQ["ICD" D
..K DRES,PDIAGARY
..D ICDDESC^ICDXCODE(PDIAGQ,PDIAGV,,.DRES)
..I '$O(DRES(0)) D TXT2ARY^PSOERXD1(.PDIAGARY,"Primary Dx: ("_PDIAGQ_" - "_PDIAGV_")"," ",78) ;,TXT2ARY^PSOERXD1(.PDIAGD,PDESC) Q
..S PDIAGTXT="Primary Dx: ("_PDIAGQ_" "_PDIAGV_") "
..S DRESL=0 F S DRESL=$O(DRES(DRESL)) Q:'DRESL D
...S DRESDAT=$G(DRES(DRESL)) Q:DRESDAT=""
...S PDIAGTXT=$G(PDIAGTXT)_" "_DRESDAT
..D TXT2ARY^PSOERXD1(.PDIAGARY,PDIAGTXT," ",78)
.S SDIAGQ=$G(DIAGDAT(52.493113,DIENS,3.2,"E"))
.S SDIAGV=$G(DIAGDAT(52.493113,DIENS,3.1,"E"))
.S SDESC=$G(DIAGDAT(52.493113,DIENS,4,"E")) D TXT2ARY^PSOERXD1(.SDESCARY,"Description: "_SDESC," ",55)
.I SDIAGQ["ICD" D
..K SDRES,SDIAGARY
..D ICDDESC^ICDXCODE(SDIAGQ,SDIAGV,,.SDRES)
..I '$O(DRES(0)) D TXT2ARY^PSOERXD1(.SDIAGARY,"Secondary Dx: ("_SDIAGQ_" - "_SDIAGV_")"," ",78) ;,TXT2ARY^PSOERXD1(.SDIAGD,SDESC) Q
..S SDIAGTXT="Secondary Dx: ("_SDIAGQ_" "_SDIAGV_") "
..S SDRESL=0 F S SDRESL=$O(SDRES(SDRESL)) Q:'SDRESL D
...S SDRESDAT=$G(SDRES(SDRESL)) Q:SDRESDAT=""
...S SDIAGTXT=$G(SDIAGTXT)_" "_SDRESDAT
..D TXT2ARY^PSOERXD1(.SDIAGARY,SDIAGTXT," ",78)
.I '$D(PDIAGARY) D TXT2ARY^PSOERXD1(.PDIAGARY,"Primary Dx: ("_PDIAGQ_" - "_PDIAGV_")"," ",78)
.S PDFRST=$O(PDIAGARY(0))
.S LINE=LINE+1
.I $D(GL) D SETGL(LINE,PDIAGARY(PDFRST))
.I '$D(GL) D SETLOC(LINE,$G(PDIAGARY(PDFRST)))
.S PDLOOP=PDFRST F S PDLOOP=$O(PDIAGARY(PDLOOP)) Q:'PDLOOP D
..S LINE=LINE+1
..I $D(GL) D SETGL(LINE," "_$G(PDIAGARY(PDLOOP)))
..I '$D(GL) D SETLOC(LINE," "_$G(PDIAGARY(PDLOOP)))
.S PDESC=0 F S PDESC=$O(PDESCARY(PDESC)) Q:'PDESC D
..S LINE=LINE+1
..I $D(GL) D SETGL(LINE," "_$G(PDESCARY(PDESC)))
..I '$D(GL) D SETLOC(LINE," "_$G(PDESCARY(PDESC)))
.S LINE=LINE+1
.I $D(GL) D SETGL(LINE,"")
.I '$D(GL) D SETLOC(LINE,"")
.I '$D(SDIAGARY) D TXT2ARY^PSOERXD1(.SDIAGARY,"Secondary Dx: ("_SDIAGQ_" - "_SDIAGV_")"," ",78)
.S SDFRST=$O(SDIAGARY(0))
.S LINE=LINE+1
.I $D(GL) D SETGL(LINE,$G(SDIAGARY(SDFRST)))
.I '$D(GL) D SETLOC(LINE,$G(SDIAGARY(SDFRST)))
.S SDLOOP=SDFRST F S SDLOOP=$O(SDIAGARY(SDLOOP)) Q:'SDLOOP D
..S LINE=LINE+1
..I $D(GL) D SETGL(LINE," "_$G(SDIAGARY(SDLOOP)))
..I '$D(GL) D SETLOC(LINE," "_$G(SDIAGARY(SDLOOP)))
.S SDESC=0 F S SDESC=$O(SDESCARY(SDESC)) Q:'SDESC D
..S LINE=LINE+1
..I $D(GL) D SETGL(LINE," "_$G(SDESCARY(SDESC)))
..I '$D(GL) D SETLOC(LINE," "_$G(SDESCARY(SDESC)))
.I $O(^PS(52.49,PSOIEN,311,MIEN,3,DIAGIEN)) D
..S LINE=LINE+1
..I $D(GL) D SETGL(LINE,"")
..I '$D(GL) D SETLOC(LINE,"")
Q
SETLOC(LINE,TEXT) ;
D SET^VALM10(LINE,TEXT)
Q
SETGL(IEN,TEXT) ;
S @GL@(IEN,0)=TEXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXU5 14135 printed Apr 09, 2024@21:33:05 Page 2
PSOERXU5 ;ALB/BWF - eRx utilities ; 4/9/2018 10:55am
+1 ;;7.0;OUTPATIENT PHARMACY;**508,581,651**;DEC 1997;Build 30
+2 ;
+3 QUIT
CANREQ(ERXIEN,LINE,PMODE) ;
+1 NEW REQIEN,REQDTTM,COMM,HUBID,CANSTAT,DNB,RESTYPE,COMM,COMMARY,COMMBY,COMMDTTM,CTXT,I,REQBY
+2 ; - the next line of code will actually reference the related message for retrieval of the cancel request information
+3 ; - check that this is correct and test.
+4 SET REQIEN=ERXIEN
+5 IF $$GET1^DIQ(52.49,ERXIEN,.08,"I")="CN"
SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
+6 IF '$$FINDNRX^PSOERXU6(REQIEN)
SET DNB=1
+7 SET HUBID=$$GET1^DIQ(52.49,REQIEN,.01,"E")
+8 SET REQBY=$$GET1^DIQ(52.49,REQIEN,2.1,"E")
+9 SET REQDTTM=$$GET1^DIQ(52.49,REQIEN,.03,"E")
+10 ;S DNB=$$GET1^DIQ(52.49,REQIEN,80.5,"I")
+11 SET COMM=$$GET1^DIQ(52.49,REQIEN,50,"E")
+12 SET RESTYPE=$$GET1^DIQ(52.49,REQIEN,52.1,"E")
+13 SET CANSTAT=$$GET1^DIQ(52.49,REQIEN,1,"I")
+14 SET CANSTAT=$$GET1^DIQ(52.45,CANSTAT,.02,"E")
+15 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+16 SET LINE=LINE+1
DO SET^VALM10(LINE,"************************CANCEL REQUEST INFORMATION**************************")
+17 IF '$GET(PMODE)
SET LINE=LINE+1
DO SET^VALM10(LINE,RESTYPE)
DO CNTRL^VALM10(LINE,1,$LENGTH(RESTYPE),IORVON,IORVOFF)
+18 SET LINE=LINE+1
DO SET^VALM10(LINE,"Request Status: "_CANSTAT)
+19 IF $LENGTH(RESTYPE)
SET LINE=LINE+1
DO SET^VALM10(LINE,"Request/Response Type: "_RESTYPE)
+20 SET LINE=LINE+1
DO SET^VALM10(LINE,"Requested By: "_REQBY)
+21 SET LINE=LINE+1
DO SET^VALM10(LINE,"Request Date/Time: "_REQDTTM)
+22 IF $GET(DNB)
SET LINE=LINE+1
DO SET^VALM10(LINE,"Original eRx not found in Hub and/or in Vista.")
+23 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+24 SET COMM=$$GET1^DIQ(52.49,REQIEN,50,"E")
+25 SET COMM="Request Comments: "_COMM
+26 DO TXT2ARY^PSOERXD1(.COMMARY,COMM," ",80)
+27 SET I=0
FOR
SET I=$ORDER(COMMARY(I))
if 'I
QUIT
Begin DoDot:1
+28 SET CTXT=$GET(COMMARY(I))
+29 SET LINE=LINE+1
DO SET^VALM10(LINE,CTXT)
End DoDot:1
+30 SET COMMBY=$$GET1^DIQ(52.49,REQIEN,50.1,"E")
+31 SET COMMDTTM=$$GET1^DIQ(52.49,REQIEN,50.2,"E")
+32 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments By: "_COMMBY)
+33 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM)
+34 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+35 QUIT
CANRES(ERXIEN,LINE,PMODE) ;
+1 NEW MTYPE,IENS,RESIEN,REQIEN,HUBID,RESVAL,RESCODE,RESNOTE,RESDTTM,CANSTAT,RESBY,COMM,COMMARY,COMMBY,COMMDTTM,ERXDAT
+2 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+3 IF MTYPE="CN"
SET RESIEN=ERXIEN
SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
+4 IF MTYPE="CA"
SET REQIEN=ERXIEN
SET RESIEN=$$GETRESP^PSOERXU2(ERXIEN)
+5 IF MTYPE="IE"
SET RESIEN=$$RESOLV^PSOERXU2(ERXIEN)
+6 SET REQIEN=$$RESOLV^PSOERXU2(RESIEN)
+7 if 'RESIEN
QUIT
+8 SET IENS=RESIEN_","
+9 DO GETS^DIQ(52.49,RESIEN,".01;.03;1;51.1;52.1;52.2;52.3","IE","ERXDAT")
+10 SET HUBID=$GET(ERXDAT(52.49,IENS,.01,"E"))
+11 SET RESVAL=$GET(ERXDAT(52.49,IENS,52.1,"E"))
+12 SET RESCODE=$GET(ERXDAT(52.49,IENS,52.1,"I"))
+13 SET RESNOTE=$GET(ERXDAT(52.49,IENS,52.2,"E"))
+14 SET RESDTTM=$GET(ERXDAT(52.49,IENS,.03,"E"))
+15 SET CANSTAT=$GET(ERXDAT(52.49,IENS,.03,"I"))
+16 SET CANSTAT=$$GET1^DIQ(52.45,CANSTAT,.02,"E")
+17 SET RESBY=$GET(ERXDAT(52.49,IENS,51.1,"E"))
+18 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+19 SET LINE=LINE+1
DO SET^VALM10(LINE,"************************CANCEL RESPONSE INFORMATION**************************")
+20 IF '$GET(PMODE)
SET LINE=LINE+1
DO SET^VALM10(LINE,RESVAL)
DO CNTRL^VALM10(LINE,1,$LENGTH(RESVAL),IORVON,IORVOFF)
+21 SET LINE=LINE+1
DO SET^VALM10(LINE,"Response Status: "_CANSTAT)
+22 IF $LENGTH(RESVAL)
SET LINE=LINE+1
DO SET^VALM10(LINE,"Request/Response Type: "_RESVAL)
+23 SET LINE=LINE+1
DO SET^VALM10(LINE,"Response: "_RESNOTE)
+24 SET LINE=LINE+1
DO SET^VALM10(LINE,"Response by: "_RESBY)
+25 SET LINE=LINE+1
DO SET^VALM10(LINE,"Response Date/Time: "_RESDTTM)
+26 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+27 SET COMM=$$GET1^DIQ(52.49,RESIEN,50,"E")
+28 SET COMM="Response Comments: "_COMM
+29 DO TXT2ARY^PSOERXD1(.COMMARY,COMM," ",80)
+30 SET I=0
FOR
SET I=$ORDER(COMMARY(I))
if 'I
QUIT
Begin DoDot:1
+31 SET CTXT=$GET(COMMARY(I))
+32 SET LINE=LINE+1
DO SET^VALM10(LINE,CTXT)
End DoDot:1
+33 SET COMMBY=$$GET1^DIQ(52.49,RESIEN,50.1,"E")
+34 SET COMMDTTM=$$GET1^DIQ(52.49,RESIEN,50.2,"E")
+35 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments By: "_COMMBY)
+36 SET LINE=LINE+1
DO SET^VALM10(LINE,"Comments Date/Time: "_COMMDTTM)
+37 SET LINE=LINE+1
DO SET^VALM10(LINE,"")
+38 QUIT
GETPAT(ERXIEN) ;
+1 NEW ERXPAT,MTYPE,REQIEN,NEWRXIEN
+2 SET ERXPAT=$$GET1^DIQ(52.49,ERXIEN,.04,"I")
+3 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+4 IF 'ERXPAT
IF "RR,CA,"[MTYPE
Begin DoDot:1
+5 SET NEWRXIEN=$$RESOLV^PSOERXU2(ERXIEN)
+6 SET ERXPAT=$$GET1^DIQ(52.49,NEWRXIEN,.04,"I")
End DoDot:1
+7 IF 'ERXPAT
IF "RE,CN,IE,"[MTYPE
Begin DoDot:1
+8 SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
if 'REQIEN
QUIT
+9 SET ERXPAT=$$GET1^DIQ(52.49,REQIEN,.04,"I")
IF ERXPAT
QUIT
+10 SET NEWRXIEN=$$RESOLV^PSOERXU2(REQIEN)
+11 SET ERXPAT=$$GET1^DIQ(52.49,NEWRXIEN,.04,"I")
End DoDot:1
+12 if 'ERXPAT
QUIT 0
+13 QUIT ERXPAT
GETPROV(ERXIEN) ;
+1 NEW ERXPRV,MTYPE,REQIEN,NEWRXIEN
+2 SET ERXPRV=$$GET1^DIQ(52.49,ERXIEN,2.1,"I")
+3 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+4 IF 'ERXPRV
IF "RR,CA,"[MTYPE
Begin DoDot:1
+5 SET NEWRXIEN=$$RESOLV^PSOERXU2(ERXIEN)
+6 SET ERXPRV=$$GET1^DIQ(52.49,NEWRXIEN,2.1,"I")
End DoDot:1
+7 IF 'ERXPRV
IF "RE,CN"[MTYPE
Begin DoDot:1
+8 SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
if 'REQIEN
QUIT
+9 SET ERXPRV=$$GET1^DIQ(52.49,REQIEN,2.1,"I")
IF ERXPRV
QUIT
+10 SET NEWRXIEN=$$RESOLV^PSOERXU2(REQIEN)
+11 SET ERXPRV=$$GET1^DIQ(52.49,NEWRXIEN,2.1,"I")
End DoDot:1
+12 if 'ERXPRV
QUIT 0
+13 QUIT ERXPRV
GETDRUG(ERXIEN) ;
+1 NEW ERXDRG,MTYPE,REQIEN,NEWRXIEN
+2 SET ERXDRG=$$GET1^DIQ(52.49,ERXIEN,3.1,"E")
+3 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+4 IF ERXDRG=""
IF "RR,CA,"[MTYPE
Begin DoDot:1
+5 SET NEWRXIEN=$$RESOLV^PSOERXU2(ERXIEN)
+6 SET ERXDRG=$$GET1^DIQ(52.49,NEWRXIEN,3.1,"E")
End DoDot:1
+7 IF 'ERXDRG
IF "RE,CN"[MTYPE
Begin DoDot:1
+8 SET REQIEN=$$RESOLV^PSOERXU2(ERXIEN)
if 'REQIEN
QUIT
+9 SET ERXDRG=$$GET1^DIQ(52.49,REQIEN,3.1,"I")
IF ERXDRG'=""
QUIT
+10 SET NEWRXIEN=$$RESOLV^PSOERXU2(REQIEN)
+11 SET ERXDRG=$$GET1^DIQ(52.49,NEWRXIEN,3.1,"I")
End DoDot:1
+12 IF ERXDRG=""
QUIT ""
+13 QUIT ERXDRG
CANACK(ERXIEN) ;
+1 NEW DIR,MTYPE,ERXSTAT,INST,RESP,RESID,Y,PSSRET,DIRUT,DTOUT,RESCHECK,MESREQ,RTMIEN,RTMTYPE
+2 DO FULL^VALM1
SET VALMBCK="R"
+3 IF $DATA(^XUSEC("PSO ERX VIEW",DUZ))
WRITE !,">>> You do not have privilege to use this option."
DO DIRE^PSOERXX1
QUIT
+4 SET MTYPE=$$GET1^DIQ(52.49,ERXIEN,.08,"I")
+5 SET RESTYPE=$$GET1^DIQ(52.49,ERXIEN,52.1,"I")
SET MESREQ=$$GET1^DIQ(52.49,ERXIEN,315.1,"E")
+6 SET ERXSTAT=$$GET1^DIQ(52.49,ERXIEN,1,"E")
+7 IF ",CAA,CXA,ICA,IEA,IRA,RXA,"[ERXSTAT
WRITE !!,"Record already acknowledged!",!,$CHAR(7)
DO DIRE^PSOERXX1
QUIT
+8 IF RESTYPE="A"!(RESTYPE="AWC")
IF MESREQ="G"!(MESREQ="T")!(MESREQ="S")!(MESREQ="OS")!(MESREQ="D")
SET RESCHECK=1
+9 IF $GET(RESCHECK)
WRITE !,"For RxChange Response Approved and Approved with changes types (G/T/S/OS/D)",!,"hidden action ACK is not available."
DO DIRE^PSOERXX1
QUIT
+10 IF MTYPE="CX"
IF RESTYPE="V"
WRITE !,"ACK is not available for RxChange Response - 'Validated' response messages."
DO DIRE^PSOERXX1
QUIT
+11 IF MTYPE="CX"
IF '$GET(RESCHECK)
Begin DoDot:1
+12 WRITE !,"Would you like to acknowledge this record?"
+13 SET DIR(0)="YO"
SET DIR("B")="N"
DO ^DIR
KILL DIR
if 'Y!($DATA(DIRUT))!($DATA(DTOUT))
QUIT
+14 IF Y=1
Begin DoDot:2
+15 DO UPDSTAT^PSOERXU1(ERXIEN,"CXA")
End DoDot:2
End DoDot:1
QUIT
+16 ;
+17 IF MTYPE="RE"!(MTYPE="IE")
IF '$DATA(^XUSEC("PSDRPH",DUZ))
IF '$DATA(^XUSEC("PSO ERX ADV TECH",DUZ))
IF '$DATA(^XUSEC("PSO ERX TECH",DUZ))
Begin DoDot:1
+18 WRITE !,"You do not have priviledge to use this option."
DO DIRE^PSOERXX1
End DoDot:1
QUIT
+19 IF MTYPE="CA"!(MTYPE="CN")
IF '$DATA(^XUSEC("PSDRPH",DUZ))
IF '$DATA(^XUSEC("PSO ERX ADV TECH",DUZ))
Begin DoDot:1
+20 WRITE !,"You do not have priviledge to use this option."
DO DIRE^PSOERXX1
End DoDot:1
QUIT
+21 IF ",CAO,CAH,CAF,CAP,CAR,CAX,RXD,RRE,RXF,CXV,CXD,CXY,CRE,"'[ERXSTAT
WRITE !,"Acknowledge cannot be used on this record status."
DO DIRE^PSOERXX1
QUIT
+22 IF (ERXSTAT="CAO")!(ERXSTAT="RXD")!(ERXSTAT="RRE")!(ERXSTAT="CRE")!(ERXSTAT="RXF")
Begin DoDot:1
+23 WRITE !,"Would you like to acknowledge this record?"
+24 SET DIR(0)="YO"
SET DIR("B")="N"
DO ^DIR
KILL DIR
if 'Y!($DATA(DIRUT))!($DATA(DTOUT))
QUIT
+25 KILL Y
+26 SET RTMIEN=$$RESOLV^PSOERXU2(ERXIEN)
SET RTMTYPE=$$GET1^DIQ(52.49,RTMIEN,.08,"I")
+27 IF MTYPE="CA"
DO UPDSTAT^PSOERXU1(ERXIEN,"CAA")
+28 IF MTYPE="RE"
DO UPDSTAT^PSOERXU1(ERXIEN,"RXA")
+29 IF MTYPE="IE"
IF RTMTYPE="RR"
DO UPDSTAT^PSOERXU1(ERXIEN,"IRA")
+30 IF MTYPE="IE"
IF RTMTYPE="CR"
DO UPDSTAT^PSOERXU1(ERXIEN,"ICA")
+31 IF MTYPE="CR"
DO UPDSTAT^PSOERXU1(ERXIEN,"ICA")
+32 WRITE !,$SELECT(MTYPE="CA":"Cancel request",MTYPE="RE":"RxRenewal response",1:"Inbound error")," acknowledged."
DO DIRE^PSOERXX1
+33 KILL @VALMAR
DO INIT^PSOERX1
End DoDot:1
QUIT
+34 SET INST=$$GET1^DIQ(52.49,ERXIEN,24.1,"I")
+35 WRITE !,"Would you like to send an 'Approved' or 'Denied' response?"
+36 KILL DIR
SET DIR(0)="SO^A:APPROVED;D:DENIED"
+37 SET DIR("?")="prescription."
+38 SET DIR("?",1)="Approved - The user was able to Cancel or Discontinue the original"
+39 SET DIR("?",2)="prescription."
+40 SET DIR("?",3)=""
+41 SET DIR("?",4)="Denied - The user was not able to Cancel or Discontinue the original"
+42 DO ^DIR
KILL DIR
if Y=""!($DATA(DIRUT))!($DATA(DTOUT))
QUIT
+43 IF Y="A"
SET RESP="Rx was never dispensed. Canceled at Pharmacy."
+44 IF Y="D"
SET RESP="Rx Not Canceled - Rx not found in pharmacy system."
+45 IF Y="A"
IF MTYPE="CA"
SET RESP="Rx canceled at Pharmacy."
+46 SET RESID=$SELECT(Y="A":3,Y="D":2,1:0)
+47 WRITE !,"Would you like to acknowledge this record?"
+48 SET DIR(0)="YO"
SET DIR("B")="N"
DO ^DIR
KILL DIR
if 'Y!($DATA(DIRUT))!($DATA(DTOUT))
QUIT
+49 DO POST^PSOERXO1(ERXIEN,.PSSRET,,,,RESID,INST,RESP)
+50 IF $DATA(PSSRET("errorMessage"))
WRITE !!,PSSRET("errorMessage")
DO DIRE^PSOERXX1
QUIT
+51 IF MTYPE="CA"
DO UPDSTAT^PSOERXU1(ERXIEN,"CAA")
+52 IF MTYPE="RE"
DO UPDSTAT^PSOERXU1(ERXIEN,"RXA")
+53 IF MTYPE="IE"
DO UPDSTAT^PSOERXU1(ERXIEN,"IRA")
+54 WRITE !,$SELECT(MTYPE="CA":"Cancel request",MTYPE="RE":"RxRenewal response",1:"Inbound error")," acknowledged."
DO DIRE^PSOERXX1
+55 KILL @VALMAR
DO INIT^PSOERX1
+56 QUIT
LASTSTAT(ERXIEN) ;
+1 NEW STAT,DONE,CSTAT,LSTAT,RSTAT
+2 SET DONE=0
SET RSTAT=""
+3 SET CSTAT=$$GET1^DIQ(52.49,ERXIEN,1,"I")
+4 SET STAT=99999
FOR
SET STAT=$ORDER(^PS(52.49,ERXIEN,19,STAT),-1)
if 'STAT!(DONE)
QUIT
Begin DoDot:1
+5 SET LSTAT=$$GET1^DIQ(52.4919,STAT_","_ERXIEN_",",.02,"I")
+6 IF LSTAT=CSTAT
QUIT
+7 SET RSTAT=$$GET1^DIQ(52.45,LSTAT,.01,"E")_" - "_$$GET1^DIQ(52.45,LSTAT,.02,"E")
SET DONE=1
End DoDot:1
+8 QUIT RSTAT
CSCOMM(ERXIEN) ;
+1 NEW STAT,DONE,SCOMM
+2 SET CSTAT=$$GET1^DIQ(52.49,ERXIEN,1,"I")
+3 SET STAT=$ORDER(^PS(52.49,ERXIEN,19,999999),-1)
IF 'STAT
QUIT ""
+4 SET SCOMM=$$GET1^DIQ(52.4919,STAT_","_ERXIEN_",",1,"E")
+5 QUIT SCOMM
COMMVAL(IEN,FILE,SUB,TYPE,EXTFLG) ; IEN, file number, communication subscript, type of communication,
+1 ; extension flag (optional)
+2 NEW CHECK,EXT,VAL,X,SFIEN,TYPEVAL
+3 SET SFIEN=0
+4 FOR
SET SFIEN=$ORDER(^PS(FILE,IEN,SUB,SFIEN))
if 'SFIEN!($GET(VAL))
QUIT
Begin DoDot:1
+5 SET TYPEVAL=$$GET1^DIQ(FILE_SUB,SFIEN_","_IEN_",",.02,"I")
+6 IF TYPEVAL=TYPE
Begin DoDot:2
+7 SET VAL=$$GET1^DIQ(FILE_SUB,SFIEN_","_IEN_",",.03)
+8 IF $GET(EXTFLG)
Begin DoDot:3
+9 SET EXT=$$GET1^DIQ(FILE_SUB,SFIEN_","_IEN_",",.04)
+10 if EXT]""
SET VAL=VAL_"X"_EXT
End DoDot:3
End DoDot:2
End DoDot:1
+11 IF '$GET(VAL)
QUIT ""
+12 QUIT VAL
EFFDATE(IEN,MIEN) ; if it exists in "other medication date" subfile, return the effective date
+1 IF 'MIEN
QUIT ""
+2 NEW OMDIEN,EFFCHECK,EFFDATE
+3 SET OMDIEN=0
+4 FOR
SET OMDIEN=$ORDER(^PS(52.49,IEN,311,MIEN,62,OMDIEN))
if 'OMDIEN!($GET(EFFDATE))
QUIT
Begin DoDot:1
+5 SET EFFCHECK=$$GET1^DIQ(52.4931162,OMDIEN_","_MIEN_","_IEN_",",.03)
+6 IF $GET(EFFCHECK)="EffectiveDate"
Begin DoDot:2
+7 SET EFFDATE=$$GET1^DIQ(52.4931162,OMDIEN_","_MIEN_","_IEN_",",.02,"E")
QUIT
End DoDot:2
End DoDot:1
+8 QUIT $GET(EFFDATE)
DIAG2017(PSOIEN,LINE,GL,MIEN) ;
+1 NEW DIAGIEN,DIAGDAT,DIAGSEQ,PDIAGQ,PDIAGV,SDIAGQ,SDIAGV,DIAGDAT,DIACIC,DRES,SDRES,PDIAGTXT,SDIAGTXT
+2 NEW SDRESL,SDRESDAT,DRESL,DRESDAT,PDIAGARY,SDIAGARY,PDFRST,SDFRST,PDLOOP,SDLOOP,DIENS,PDESC,SDESC,PDESCARY,SDESCARY
+3 if '$GET(MIEN)
QUIT
+4 SET DIAGIEN=0
FOR
SET DIAGIEN=$ORDER(^PS(52.49,PSOIEN,311,MIEN,3,DIAGIEN))
if 'DIAGIEN
QUIT
Begin DoDot:1
+5 SET DIENS=DIAGIEN_","_MIEN_","_PSOIEN_","
KILL PDIAGARY,SDIAGARY,DIAGDAT
+6 DO GETS^DIQ(52.493113,DIENS,"**","IE","DIAGDAT")
+7 SET DIAGSEQ=$GET(DIAGDAT(52.493113,DIENS,.01,"E"))
+8 SET DIACIC=$GET(DIAGDAT(52.493113,DIENS,.02,"E"))
+9 SET PDIAGQ=$GET(DIAGDAT(52.493113,DIENS,1.2,"E"))
+10 SET PDIAGV=$GET(DIAGDAT(52.493113,DIENS,1.1,"E"))
+11 SET PDESC=$GET(DIAGDAT(52.493113,DIENS,2,"E"))
DO TXT2ARY^PSOERXD1(.PDESCARY,"Description: "_PDESC," ",55)
+12 IF PDIAGQ["ICD"
Begin DoDot:2
+13 KILL DRES,PDIAGARY
+14 DO ICDDESC^ICDXCODE(PDIAGQ,PDIAGV,,.DRES)
+15 ;,TXT2ARY^PSOERXD1(.PDIAGD,PDESC) Q
IF '$ORDER(DRES(0))
DO TXT2ARY^PSOERXD1(.PDIAGARY,"Primary Dx: ("_PDIAGQ_" - "_PDIAGV_")"," ",78)
+16 SET PDIAGTXT="Primary Dx: ("_PDIAGQ_" "_PDIAGV_") "
+17 SET DRESL=0
FOR
SET DRESL=$ORDER(DRES(DRESL))
if 'DRESL
QUIT
Begin DoDot:3
+18 SET DRESDAT=$GET(DRES(DRESL))
if DRESDAT=""
QUIT
+19 SET PDIAGTXT=$GET(PDIAGTXT)_" "_DRESDAT
End DoDot:3
+20 DO TXT2ARY^PSOERXD1(.PDIAGARY,PDIAGTXT," ",78)
End DoDot:2
+21 SET SDIAGQ=$GET(DIAGDAT(52.493113,DIENS,3.2,"E"))
+22 SET SDIAGV=$GET(DIAGDAT(52.493113,DIENS,3.1,"E"))
+23 SET SDESC=$GET(DIAGDAT(52.493113,DIENS,4,"E"))
DO TXT2ARY^PSOERXD1(.SDESCARY,"Description: "_SDESC," ",55)
+24 IF SDIAGQ["ICD"
Begin DoDot:2
+25 KILL SDRES,SDIAGARY
+26 DO ICDDESC^ICDXCODE(SDIAGQ,SDIAGV,,.SDRES)
+27 ;,TXT2ARY^PSOERXD1(.SDIAGD,SDESC) Q
IF '$ORDER(DRES(0))
DO TXT2ARY^PSOERXD1(.SDIAGARY,"Secondary Dx: ("_SDIAGQ_" - "_SDIAGV_")"," ",78)
+28 SET SDIAGTXT="Secondary Dx: ("_SDIAGQ_" "_SDIAGV_") "
+29 SET SDRESL=0
FOR
SET SDRESL=$ORDER(SDRES(SDRESL))
if 'SDRESL
QUIT
Begin DoDot:3
+30 SET SDRESDAT=$GET(SDRES(SDRESL))
if SDRESDAT=""
QUIT
+31 SET SDIAGTXT=$GET(SDIAGTXT)_" "_SDRESDAT
End DoDot:3
+32 DO TXT2ARY^PSOERXD1(.SDIAGARY,SDIAGTXT," ",78)
End DoDot:2
+33 IF '$DATA(PDIAGARY)
DO TXT2ARY^PSOERXD1(.PDIAGARY,"Primary Dx: ("_PDIAGQ_" - "_PDIAGV_")"," ",78)
+34 SET PDFRST=$ORDER(PDIAGARY(0))
+35 SET LINE=LINE+1
+36 IF $DATA(GL)
DO SETGL(LINE,PDIAGARY(PDFRST))
+37 IF '$DATA(GL)
DO SETLOC(LINE,$GET(PDIAGARY(PDFRST)))
+38 SET PDLOOP=PDFRST
FOR
SET PDLOOP=$ORDER(PDIAGARY(PDLOOP))
if 'PDLOOP
QUIT
Begin DoDot:2
+39 SET LINE=LINE+1
+40 IF $DATA(GL)
DO SETGL(LINE," "_$GET(PDIAGARY(PDLOOP)))
+41 IF '$DATA(GL)
DO SETLOC(LINE," "_$GET(PDIAGARY(PDLOOP)))
End DoDot:2
+42 SET PDESC=0
FOR
SET PDESC=$ORDER(PDESCARY(PDESC))
if 'PDESC
QUIT
Begin DoDot:2
+43 SET LINE=LINE+1
+44 IF $DATA(GL)
DO SETGL(LINE," "_$GET(PDESCARY(PDESC)))
+45 IF '$DATA(GL)
DO SETLOC(LINE," "_$GET(PDESCARY(PDESC)))
End DoDot:2
+46 SET LINE=LINE+1
+47 IF $DATA(GL)
DO SETGL(LINE,"")
+48 IF '$DATA(GL)
DO SETLOC(LINE,"")
+49 IF '$DATA(SDIAGARY)
DO TXT2ARY^PSOERXD1(.SDIAGARY,"Secondary Dx: ("_SDIAGQ_" - "_SDIAGV_")"," ",78)
+50 SET SDFRST=$ORDER(SDIAGARY(0))
+51 SET LINE=LINE+1
+52 IF $DATA(GL)
DO SETGL(LINE,$GET(SDIAGARY(SDFRST)))
+53 IF '$DATA(GL)
DO SETLOC(LINE,$GET(SDIAGARY(SDFRST)))
+54 SET SDLOOP=SDFRST
FOR
SET SDLOOP=$ORDER(SDIAGARY(SDLOOP))
if 'SDLOOP
QUIT
Begin DoDot:2
+55 SET LINE=LINE+1
+56 IF $DATA(GL)
DO SETGL(LINE," "_$GET(SDIAGARY(SDLOOP)))
+57 IF '$DATA(GL)
DO SETLOC(LINE," "_$GET(SDIAGARY(SDLOOP)))
End DoDot:2
+58 SET SDESC=0
FOR
SET SDESC=$ORDER(SDESCARY(SDESC))
if 'SDESC
QUIT
Begin DoDot:2
+59 SET LINE=LINE+1
+60 IF $DATA(GL)
DO SETGL(LINE," "_$GET(SDESCARY(SDESC)))
+61 IF '$DATA(GL)
DO SETLOC(LINE," "_$GET(SDESCARY(SDESC)))
End DoDot:2
+62 IF $ORDER(^PS(52.49,PSOIEN,311,MIEN,3,DIAGIEN))
Begin DoDot:2
+63 SET LINE=LINE+1
+64 IF $DATA(GL)
DO SETGL(LINE,"")
+65 IF '$DATA(GL)
DO SETLOC(LINE,"")
End DoDot:2
End DoDot:1
+66 QUIT
SETLOC(LINE,TEXT) ;
+1 DO SET^VALM10(LINE,TEXT)
+2 QUIT
SETGL(IEN,TEXT) ;
+1 SET @GL@(IEN,0)=TEXT
+2 QUIT
