SD53P215 ;BP-OIFO/KEITH - PRE/POST INSTALL SD*5.3*215 ; 27 Apr 2000 12:49 PM
;;5.3;Scheduling;**215,1015**;Aug 13 1993;Build 21
;
ENV I DUZ(0)'="@" D
.W !!,$C(7)," To insure that data updates contained in this patch are",!," installed correctly, DUZ(0) must be equal the ""@"" symbol!",!
.S XPDQUIT=2 Q
Q
;
POST ;Post init actions
D SEED,CODE Q
;
SEED ;Seed NPCD ENCOUNTER MONTH multiple (#404.9171) of the SCHEDULING
;PARAMETER file (#404.91) with revised database close-out dates
;for FY2000
;
;Declare variables
N XPDIDTOT,LINE,DATES,WLMONTH,DBCLOSE,WLCLOSE,TMP
;Print header
D BMES^XPDUTL(">>> Storing revised database close-out dates for Fiscal Year 2000")
S TMP=$$INSERT^SCDXUTL1("Workload","",7)
S TMP=$$INSERT^SCDXUTL1("Database",TMP,27)
S TMP=$$INSERT^SCDXUTL1("Workload",TMP,47)
D BMES^XPDUTL(TMP)
S TMP=$$INSERT^SCDXUTL1("Occurred In","",6)
S TMP=$$INSERT^SCDXUTL1("Close-Out",TMP,27)
S TMP=$$INSERT^SCDXUTL1("Close-Out",TMP,47)
D MES^XPDUTL(TMP)
S TMP=$$INSERT^SCDXUTL1("------------","",5)
S TMP=$$INSERT^SCDXUTL1("------------",TMP,25)
S TMP=$$INSERT^SCDXUTL1("------------",TMP,45)
D MES^XPDUTL(TMP)
;Loop through list of dates
S XPDIDTOT=6
F LINE=2:1:7 S TMP=$T(FY00+LINE),DATES=$P(TMP,";",3) Q:(DATES="") D
.;Break out info
.S WLMONTH=$P(DATES,"^",1)
.S DBCLOSE=$P(DATES,"^",2)
.S WLCLOSE=$P(DATES,"^",3)
.;Print close-out info
.S TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(WLMONTH,"1D"),"",7)
.S TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(DBCLOSE,"1D"),TMP,25)
.S TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(WLCLOSE,"1D"),TMP,45)
.D MES^XPDUTL(TMP)
.;Store close-out info
.S TMP=$$AECLOSE^SCDXFU04(WLMONTH,DBCLOSE,WLCLOSE)
.;Write error message if datebase or workload dates not updated
.I TMP<0 D MES^XPDUTL(" >>> Could not update closeout dates for above month.")
.;If KIDS install, show progress through status bar
.D:($G(XPDNM)'="") UPDATE^XPDID(LINE-1)
D BMES^XPDUTL("")
Q
;
FY00 ;Revised Close-out dates for fiscal year 2000
; Month ^ Database Close-Out ^ Workload Close-Out
;;2991000^3001013^2991112
;;2991100^3001013^2991210
;;2991200^3001013^3000107
;;3000100^3001013^3000211
;;3000200^3001013^3000310
;;3000300^3001013^3000407
Q
;
CODE ;File new code to TRANSMITTED OUTPATIENT ENCOUNTER ERROR CODE file
;(#409.76)
;
N SDY
S SDY=$$FILE()
I SDY=-1 D Q
.D MES^XPDUTL(">>> Unable to file error code '999', contact Customer Service for assistance.")
.Q
I $P(SDY,U,3)'=1 D Q
.D MES^XPDUTL(">>> Error code '999' is already on file, no action taken.")
.Q
D MES^XPDUTL(">>> Error code '999 - Unknown reason' added to file #409.76.")
Q
;
FILE() ;File code
N DIC,DLAYGO,X,Y,SD
S SD(.02)="NPCD",SD(11)="Reason unknown"
S SD(21)="Rejected by NPCD without a valid reason, use the 'Retransmit Selected Error Code' [SCDX AMBCAR RETRANS ERROR] option to resend."
S SD(41)="S RTN=$$MSG^SCENIA1(""Use the 'Retransmit Selected Error Code' [SCDX AMBCAR RETRANS ERROR] option to resend."")"
S DIC="^SD(409.76,",DLAYGO=409.76,DIC(0)="L",X=999
S DIC("DR")=".02///^S X=SD(.02);11///^S X=SD(11);21///^S X=SD(21);41///^S X=SD(41)"
D ^DIC
Q Y
;
FIND ;Mark encounters that have been rejected for transmission due to the
;midyear database closeout or have been transmitted but rejected by
;NPCD without a valid reason for retransmission
;
N SDSTAT
I DT>3001013 W !!,$C(7),"It is too late to run this utility!" Q
I $G(DUZ)<1 W !!,$C(7),"DUZ must be defined to run this utility!" Q
S SDSTAT=$O(^SD(409.63,"B","CHECKED OUT",0)) I 'SDSTAT W !!,"CHECKED OUT encounter status could not be identified!" K SDSTAT Q
N ZTSAVE S ZTSAVE("SDSTAT")=""
W ! D EN^XUTMDEVQ("START^SD53P215","Re-flag NPCDB activity",.ZTSAVE) Q
;
START ;Search for activity to re-flag for transmission
;
N SDLINE,SDOUT,SDTIT,SDPAGE,X,Y,%,SDPNOW,SDDT,SDOE,SDOE0,SDSTX,SDTOT
N SDCT,SDXP,SDTEXT,SDSCT,SDSTOT
;Initialize variables
K ^TMP("SD215",$J)
S SDLINE="",$P(SDLINE,"-",(IOM+1))="",SDOUT=0
S SDTIT="<*> RE-FLAG UNSENT/REJECTED FY2000 NPCDB ACTIVITY FOR TRANSMISSION <*>"
S SDPAGE=1 D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=Y
;Search encounters by date range
S SDDT=2991000
F S SDDT=$O(^SCE("B",SDDT)) Q:'SDDT S SDOE=0 F S SDOE=$O(^SCE("B",SDDT,SDOE)) Q:'SDOE D
.S SDOE0=$G(^SCE(SDOE,0)) Q:'$L(SDOE0)
.;If date/patient/location/status/transmission status, set array
.I $P(SDOE0,U),$P(SDOE0,U,2),$P(SDOE0,U,4),$P(SDOE0,U,12)=SDSTAT,'$P(SDOE0,U,6) S SDSTX=$$STX^SCRPW8(SDOE,SDOE0) I "1^2^3^6"[+SDSTX D
..S ^TMP("SD215",$J,+SDSTX,"CT")=$G(^TMP("SD215",$J,+SDSTX,"CT"))+1
..S ^TMP("SD215",$J,+SDSTX,"TEXT")=SDSTX
..S ^TMP("SD215",$J,+SDSTX,SDOE)=SDOE0
..Q
.Q
;Count records found
S (SDSTX,SDTOT)=0 F S SDSTX=$O(^TMP("SD215",$J,SDSTX)) Q:'SDSTX S SDTOT=SDTOT+^TMP("SD215",$J,SDSTX,"CT")
;
;Re-flag encounters for transmission
S (SDCT,SDSTX,SDOUT)=0
F S SDSTX=$O(^TMP("SD215",$J,SDSTX)) Q:'SDSTX!SDOUT D
.S SDOE=0 F S SDOE=$O(^TMP("SD215",$J,SDSTX,SDOE)) Q:'SDOE!SDOUT D
..S SDDT=+^TMP("SD215",$J,SDSTX,SDOE)
..S SDXP=$$CRTXMIT^SCDXFU01(SDOE,,SDDT) ;Get the transmission record
..Q:SDXP'>0
..;Keep count by transmission status
..S ^TMP("SD215",$J,SDSTX,"SENT")=$G(^TMP("SD215",$J,SDSTX,"SENT"))+1
..S SDCT=SDCT+1 S:SDCT'<5000 SDOUT=1 ;Don't do more than 5000
..D STREEVNT^SCDXFU01(SDXP,0) ;Log the event
..D XMITFLAG^SCDXFU01(SDXP,0) ;Flag the record for transmission
..Q
.Q
;
;Report the results
N SD,SDI,SDX S SDI=0
;Set text array
D LINE("")
D LINE(" Unsent/rejected FY2000 NPCD activity found")
D LINE(" ------------------------------------------")
S SDSTX=0 F S SDSTX=$O(^TMP("SD215",$J,SDSTX)) Q:'SDSTX D
.S SDTEXT=$P(^TMP("SD215",$J,SDSTX,"TEXT"),U,2)
.S SDSCT=^TMP("SD215",$J,SDSTX,"CT"),SDX=""
.S $E(SDX,20)=$J(SDTEXT,30)_": "_$J(SDSCT,6,0) D LINE(SDX)
.Q
S SDX="",$E(SDX,20)=$J("TOTAL",30)_": "_$J(SDTOT,6,0) D LINE(SDX)
D LINE("")
D LINE(" Encounters flagged for transmission")
D LINE(" -----------------------------------")
S (SDSTOT,SDSTX)=0 F S SDSTX=$O(^TMP("SD215",$J,SDSTX)) Q:'SDSTX D
.S SDTEXT=$P(^TMP("SD215",$J,SDSTX,"TEXT"),U,2)
.S SDSCT=+$G(^TMP("SD215",$J,SDSTX,"SENT")),SDSTOT=SDSTOT+SDSCT
.S SDX="",$E(SDX,20)=$J(SDTEXT,30)_": "_$J(SDSCT,6,0) D LINE(SDX)
.Q
S SDX="",$E(SDX,20)=$J("TOTAL",30)_": "_$J(SDSTOT,6,0) D LINE(SDX)
I SDTOT>5000 D
.D LINE(""),LINE("")
.D LINE(" More than 5000 encounters were found that require retransmission. To avoid")
.D LINE(" overloading HL7 and MailMan globals, this process is designed to send no")
.D LINE(" more than 5000 encounters at a time. To complete the transmission of all")
.D LINE(" applicable activity, you are advised to re-run this utility on a subsequent")
.D LINE(" date.")
.Q
;
MAIL ;Send mail message
N XMSUB,XMDUZ,XMDUN,XMTEXT,XMY,XMZ
S XMSUB="Encounter retransmission utility"
S (XMDUN,XMDUZ)="Patch SD*5.3*215"
S XMTEXT="SD(",XMY(DUZ)=""
D ^XMD
;
PRINT ;Print report
D HDR
N COL S COL=(IOM-80\2)
S SDI=0 F S SDI=$O(SD(SDI)) Q:'SDI D
.D:$Y>(IOSL-3) HDR
.W !?(COL),SD(SDI)
.Q
;
EXIT K ^TMP("SD215",$J) Q
;
;
LINE(SDX) ;Create text array node
S SDI=SDI+1,SD(SDI)=SDX
Q
;
HDR ;Print report header
W:SDPAGE>1 @IOF
W SDLINE,!?(IOM-$L(SDTIT)\2),SDTIT,!,SDLINE,!,"Date printed:",SDPNOW
W ?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q
SD53P215 ;BP-OIFO/KEITH - PRE/POST INSTALL SD*5.3*215 ; 27 Apr 2000 12:49 PM
+1 ;;5.3;Scheduling;**215,1015**;Aug 13 1993;Build 21
+2 ;
ENV IF DUZ(0)'="@"
Begin DoDot:1
+1 WRITE !!,$CHAR(7)," To insure that data updates contained in this patch are",!," installed correctly, DUZ(0) must be equal the ""@"" symbol!",!
+2 SET XPDQUIT=2
QUIT
End DoDot:1
+3 QUIT
+4 ;
POST ;Post init actions
+1 DO SEED
DO CODE
QUIT
+2 ;
SEED ;Seed NPCD ENCOUNTER MONTH multiple (#404.9171) of the SCHEDULING
+1 ;PARAMETER file (#404.91) with revised database close-out dates
+2 ;for FY2000
+3 ;
+4 ;Declare variables
+5 NEW XPDIDTOT,LINE,DATES,WLMONTH,DBCLOSE,WLCLOSE,TMP
+6 ;Print header
+7 DO BMES^XPDUTL(">>> Storing revised database close-out dates for Fiscal Year 2000")
+8 SET TMP=$$INSERT^SCDXUTL1("Workload","",7)
+9 SET TMP=$$INSERT^SCDXUTL1("Database",TMP,27)
+10 SET TMP=$$INSERT^SCDXUTL1("Workload",TMP,47)
+11 DO BMES^XPDUTL(TMP)
+12 SET TMP=$$INSERT^SCDXUTL1("Occurred In","",6)
+13 SET TMP=$$INSERT^SCDXUTL1("Close-Out",TMP,27)
+14 SET TMP=$$INSERT^SCDXUTL1("Close-Out",TMP,47)
+15 DO MES^XPDUTL(TMP)
+16 SET TMP=$$INSERT^SCDXUTL1("------------","",5)
+17 SET TMP=$$INSERT^SCDXUTL1("------------",TMP,25)
+18 SET TMP=$$INSERT^SCDXUTL1("------------",TMP,45)
+19 DO MES^XPDUTL(TMP)
+20 ;Loop through list of dates
+21 SET XPDIDTOT=6
+22 FOR LINE=2:1:7
SET TMP=$TEXT(FY00+LINE)
SET DATES=$PIECE(TMP,";",3)
IF (DATES="")
QUIT
Begin DoDot:1
+23 ;Break out info
+24 SET WLMONTH=$PIECE(DATES,"^",1)
+25 SET DBCLOSE=$PIECE(DATES,"^",2)
+26 SET WLCLOSE=$PIECE(DATES,"^",3)
+27 ;Print close-out info
+28 SET TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(WLMONTH,"1D"),"",7)
+29 SET TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(DBCLOSE,"1D"),TMP,25)
+30 SET TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(WLCLOSE,"1D"),TMP,45)
+31 DO MES^XPDUTL(TMP)
+32 ;Store close-out info
+33 SET TMP=$$AECLOSE^SCDXFU04(WLMONTH,DBCLOSE,WLCLOSE)
+34 ;Write error message if datebase or workload dates not updated
+35 IF TMP<0
DO MES^XPDUTL(" >>> Could not update closeout dates for above month.")
+36 ;If KIDS install, show progress through status bar
+37 IF ($GET(XPDNM)'="")
DO UPDATE^XPDID(LINE-1)
End DoDot:1
+38 DO BMES^XPDUTL("")
+39 QUIT
+40 ;
FY00 ;Revised Close-out dates for fiscal year 2000
+1 ; Month ^ Database Close-Out ^ Workload Close-Out
+2 ;;2991000^3001013^2991112
+3 ;;2991100^3001013^2991210
+4 ;;2991200^3001013^3000107
+5 ;;3000100^3001013^3000211
+6 ;;3000200^3001013^3000310
+7 ;;3000300^3001013^3000407
+8 QUIT
+9 ;
CODE ;File new code to TRANSMITTED OUTPATIENT ENCOUNTER ERROR CODE file
+1 ;(#409.76)
+2 ;
+3 NEW SDY
+4 SET SDY=$$FILE()
+5 IF SDY=-1
Begin DoDot:1
+6 DO MES^XPDUTL(">>> Unable to file error code '999', contact Customer Service for assistance.")
+7 QUIT
End DoDot:1
QUIT
+8 IF $PIECE(SDY,U,3)'=1
Begin DoDot:1
+9 DO MES^XPDUTL(">>> Error code '999' is already on file, no action taken.")
+10 QUIT
End DoDot:1
QUIT
+11 DO MES^XPDUTL(">>> Error code '999 - Unknown reason' added to file #409.76.")
+12 QUIT
+13 ;
FILE() ;File code
+1 NEW DIC,DLAYGO,X,Y,SD
+2 SET SD(.02)="NPCD"
SET SD(11)="Reason unknown"
+3 SET SD(21)="Rejected by NPCD without a valid reason, use the 'Retransmit Selected Error Code' [SCDX AMBCAR RETRANS ERROR] option to resend."
+4 SET SD(41)="S RTN=$$MSG^SCENIA1(""Use the 'Retransmit Selected Error Code' [SCDX AMBCAR RETRANS ERROR] option to resend."")"
+5 SET DIC="^SD(409.76,"
SET DLAYGO=409.76
SET DIC(0)="L"
SET X=999
+6 SET DIC("DR")=".02///^S X=SD(.02);11///^S X=SD(11);21///^S X=SD(21);41///^S X=SD(41)"
+7 DO ^DIC
+8 QUIT Y
+9 ;
FIND ;Mark encounters that have been rejected for transmission due to the
+1 ;midyear database closeout or have been transmitted but rejected by
+2 ;NPCD without a valid reason for retransmission
+3 ;
+4 NEW SDSTAT
+5 IF DT>3001013
WRITE !!,$CHAR(7),"It is too late to run this utility!"
QUIT
+6 IF $GET(DUZ)<1
WRITE !!,$CHAR(7),"DUZ must be defined to run this utility!"
QUIT
+7 SET SDSTAT=$ORDER(^SD(409.63,"B","CHECKED OUT",0))
IF 'SDSTAT
WRITE !!,"CHECKED OUT encounter status could not be identified!"
KILL SDSTAT
QUIT
+8 NEW ZTSAVE
SET ZTSAVE("SDSTAT")=""
+9 WRITE !
DO EN^XUTMDEVQ("START^SD53P215","Re-flag NPCDB activity",.ZTSAVE)
QUIT
+10 ;
START ;Search for activity to re-flag for transmission
+1 ;
+2 NEW SDLINE,SDOUT,SDTIT,SDPAGE,X,Y,%,SDPNOW,SDDT,SDOE,SDOE0,SDSTX,SDTOT
+3 NEW SDCT,SDXP,SDTEXT,SDSCT,SDSTOT
+4 ;Initialize variables
+5 KILL ^TMP("SD215",$JOB)
+6 SET SDLINE=""
SET $PIECE(SDLINE,"-",(IOM+1))=""
SET SDOUT=0
+7 SET SDTIT="<*> RE-FLAG UNSENT/REJECTED FY2000 NPCDB ACTIVITY FOR TRANSMISSION <*>"
+8 SET SDPAGE=1
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET SDPNOW=Y
+9 ;Search encounters by date range
+10 SET SDDT=2991000
+11 FOR
SET SDDT=$ORDER(^SCE("B",SDDT))
IF 'SDDT
QUIT
SET SDOE=0
FOR
SET SDOE=$ORDER(^SCE("B",SDDT,SDOE))
IF 'SDOE
QUIT
Begin DoDot:1
+12 SET SDOE0=$GET(^SCE(SDOE,0))
IF '$LENGTH(SDOE0)
QUIT
+13 ;If date/patient/location/status/transmission status, set array
+14 IF $PIECE(SDOE0,U)
IF $PIECE(SDOE0,U,2)
IF $PIECE(SDOE0,U,4)
IF $PIECE(SDOE0,U,12)=SDSTAT
IF '$PIECE(SDOE0,U,6)
SET SDSTX=$$STX^SCRPW8(SDOE,SDOE0)
IF "1^2^3^6"[+SDSTX
Begin DoDot:2
+15 SET ^TMP("SD215",$JOB,+SDSTX,"CT")=$GET(^TMP("SD215",$JOB,+SDSTX,"CT"))+1
+16 SET ^TMP("SD215",$JOB,+SDSTX,"TEXT")=SDSTX
+17 SET ^TMP("SD215",$JOB,+SDSTX,SDOE)=SDOE0
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 ;Count records found
+21 SET (SDSTX,SDTOT)=0
FOR
SET SDSTX=$ORDER(^TMP("SD215",$JOB,SDSTX))
IF 'SDSTX
QUIT
SET SDTOT=SDTOT+^TMP("SD215",$JOB,SDSTX,"CT")
+22 ;
+23 ;Re-flag encounters for transmission
+24 SET (SDCT,SDSTX,SDOUT)=0
+25 FOR
SET SDSTX=$ORDER(^TMP("SD215",$JOB,SDSTX))
IF 'SDSTX!SDOUT
QUIT
Begin DoDot:1
+26 SET SDOE=0
FOR
SET SDOE=$ORDER(^TMP("SD215",$JOB,SDSTX,SDOE))
IF 'SDOE!SDOUT
QUIT
Begin DoDot:2
+27 SET SDDT=+^TMP("SD215",$JOB,SDSTX,SDOE)
+28 ;Get the transmission record
SET SDXP=$$CRTXMIT^SCDXFU01(SDOE,,SDDT)
+29 IF SDXP'>0
QUIT
+30 ;Keep count by transmission status
+31 SET ^TMP("SD215",$JOB,SDSTX,"SENT")=$GET(^TMP("SD215",$JOB,SDSTX,"SENT"))+1
+32 ;Don't do more than 5000
SET SDCT=SDCT+1
IF SDCT'<5000
SET SDOUT=1
+33 ;Log the event
DO STREEVNT^SCDXFU01(SDXP,0)
+34 ;Flag the record for transmission
DO XMITFLAG^SCDXFU01(SDXP,0)
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
+37 ;
+38 ;Report the results
+39 NEW SD,SDI,SDX
SET SDI=0
+40 ;Set text array
+41 DO LINE("")
+42 DO LINE(" Unsent/rejected FY2000 NPCD activity found")
+43 DO LINE(" ------------------------------------------")
+44 SET SDSTX=0
FOR
SET SDSTX=$ORDER(^TMP("SD215",$JOB,SDSTX))
IF 'SDSTX
QUIT
Begin DoDot:1
+45 SET SDTEXT=$PIECE(^TMP("SD215",$JOB,SDSTX,"TEXT"),U,2)
+46 SET SDSCT=^TMP("SD215",$JOB,SDSTX,"CT")
SET SDX=""
+47 SET $EXTRACT(SDX,20)=$JUSTIFY(SDTEXT,30)_": "_$JUSTIFY(SDSCT,6,0)
DO LINE(SDX)
+48 QUIT
End DoDot:1
+49 SET SDX=""
SET $EXTRACT(SDX,20)=$JUSTIFY("TOTAL",30)_": "_$JUSTIFY(SDTOT,6,0)
DO LINE(SDX)
+50 DO LINE("")
+51 DO LINE(" Encounters flagged for transmission")
+52 DO LINE(" -----------------------------------")
+53 SET (SDSTOT,SDSTX)=0
FOR
SET SDSTX=$ORDER(^TMP("SD215",$JOB,SDSTX))
IF 'SDSTX
QUIT
Begin DoDot:1
+54 SET SDTEXT=$PIECE(^TMP("SD215",$JOB,SDSTX,"TEXT"),U,2)
+55 SET SDSCT=+$GET(^TMP("SD215",$JOB,SDSTX,"SENT"))
SET SDSTOT=SDSTOT+SDSCT
+56 SET SDX=""
SET $EXTRACT(SDX,20)=$JUSTIFY(SDTEXT,30)_": "_$JUSTIFY(SDSCT,6,0)
DO LINE(SDX)
+57 QUIT
End DoDot:1
+58 SET SDX=""
SET $EXTRACT(SDX,20)=$JUSTIFY("TOTAL",30)_": "_$JUSTIFY(SDSTOT,6,0)
DO LINE(SDX)
+59 IF SDTOT>5000
Begin DoDot:1
+60 DO LINE("")
DO LINE("")
+61 DO LINE(" More than 5000 encounters were found that require retransmission. To avoid")
+62 DO LINE(" overloading HL7 and MailMan globals, this process is designed to send no")
+63 DO LINE(" more than 5000 encounters at a time. To complete the transmission of all")
+64 DO LINE(" applicable activity, you are advised to re-run this utility on a subsequent")
+65 DO LINE(" date.")
+66 QUIT
End DoDot:1
+67 ;
MAIL ;Send mail message
+1 NEW XMSUB,XMDUZ,XMDUN,XMTEXT,XMY,XMZ
+2 SET XMSUB="Encounter retransmission utility"
+3 SET (XMDUN,XMDUZ)="Patch SD*5.3*215"
+4 SET XMTEXT="SD("
SET XMY(DUZ)=""
+5 DO ^XMD
+6 ;
PRINT ;Print report
+1 DO HDR
+2 NEW COL
SET COL=(IOM-80\2)
+3 SET SDI=0
FOR
SET SDI=$ORDER(SD(SDI))
IF 'SDI
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-3)
DO HDR
+5 WRITE !?(COL),SD(SDI)
+6 QUIT
End DoDot:1
+7 ;
EXIT KILL ^TMP("SD215",$JOB)
QUIT
+1 ;
+2 ;
LINE(SDX) ;Create text array node
+1 SET SDI=SDI+1
SET SD(SDI)=SDX
+2 QUIT
+3 ;
HDR ;Print report header
+1 IF SDPAGE>1
WRITE @IOF
+2 WRITE SDLINE,!?(IOM-$LENGTH(SDTIT)\2),SDTIT,!,SDLINE,!,"Date printed:",SDPNOW
+3 WRITE ?(IOM-6-$LENGTH(SDPAGE)),"Page: ",SDPAGE,!,SDLINE
SET SDPAGE=SDPAGE+1
QUIT
