Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSOERXU5

PSOERXU5.m

Go to the documentation of this file.
PSOERXU5 ;ALB/BWF - eRx utilities ; 4/9/2018 10:55am
 ;;7.0;OUTPATIENT PHARMACY;**508,581**;DEC 1997;Build 126
 ;
 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")
 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
 S ERXSTAT=$$GET1^DIQ(52.49,ERXIEN,1,"E")
 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