SD53198P ;BP-CIOFO/NDH - POST INSTALL SD*5.3*198 ; 20 Aug 99 09:00 AM
;;5.3;Scheduling;**198**;Aug 13 1993
;
SEED ;Seed NPCD ENCOUNTER MONTH multiple (#404.9171) of the SCHEDULING
; PARAMETER file (#404.91) with workload close-out dates for FY2000
;
;Declare variables
N XPDIDTOT,LINE,DATES,WLMONTH,DBCLOSE,WLCLOSE,TMP
;Print header
D BMES^XPDUTL(">>> Storing revised close-out dates for Fiscal Year 1999")
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("Occured 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(FY99+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("")
;Print header
D BMES^XPDUTL(">>> Storing 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("Occured 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=12
F LINE=2:1:13 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
;
FY99 ;Revised Close-out dates for fiscal year 2000
; Month ^ Database Close-Out ^ Workload Close-Out
;;2981000^2991015^2981106
;;2981100^2991015^2981211
;;2981200^2991015^2990108
;;2990100^2991015^2990212
;;2990200^2991015^2990312
;;2990300^2991015^2990409
;
FY00 ;Revised Close-out dates for fiscal year 2000
; Month ^ Database Close-Out ^ Workload Close-Out
;;2991000^3000414^2991112
;;2991100^3000414^2991210
;;2991200^3000414^3000107
;;3000100^3000414^3000211
;;3000200^3000414^3000310
;;3000300^3000414^3000407
;;3000400^3001013^3000512
;;3000500^3001013^3000609
;;3000600^3001013^3000707
;;3000700^3001013^3000811
;;3000800^3001013^3000908
;;3000900^3001013^3001006
;
Q ; End Part One -
; Mark unsent FY1999 Q1 & Q2 NPCDB activity for transmission
EN I DT>2991015 W !!,$C(7),"It is too late 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")="",ZTSAVE("SDFORCE")=""
W ! D EN^XUTMDEVQ("START^SD53198P","Re-flag NPCDB activity",.ZTSAVE) Q
;
START ;Search for activity to re-flag for transmission
K ^TMP("SD198",$J)
S SDLINE="",$P(SDLINE,"-",(IOM+1))=""
S SDTIT="<*> RE-FLAG UNSENT FY1999 Q1 & Q2 NPCDB ACTIVITY FOR TRANSMISSION <*>"
S SDPAGE=1 D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=Y
S SDDT=2981000
F S SDDT=$O(^SCE("B",SDDT)) Q:'SDDT!(SDDT>2990399) S SDOE=0 F S SDOE=$O(^SCE("B",SDDT,SDOE)) Q:'SDOE D
.S SDOE0=$G(^SCE(SDOE,0)) Q:'$L(SDOE0)
.I $P(SDOE0,U),$P(SDOE0,U,2),$P(SDOE0,U,4),$P(SDOE0,U,12)=SDSTAT,'$P(SDOE0,U,6),"2^3^6"[$P($$STX^SCRPW8(SDOE,SDOE0),U) D
..S ^TMP("SD198",$J,SDOE)=SDOE0
..Q
.Q
S (SDOE,SDCT)=0 F S SDOE=$O(^TMP("SD198",$J,SDOE)) Q:'SDOE S SDCT=SDCT+1
;
;Too many to send!
I '$G(SDFORCE),SDCT>3000 D G EXIT
.D HDR N C S C=(IOM-80\2) S:C<0 C=0
.W !!?(C),"This process found ",SDCT," encounters that appear not to have been",!?(C),"transmitted. This may be due to transmission data being purgedat this site"
.W !?(C),"through the use of the 'Purge Ambulatory Care Reporting files' [SCDX AMBCAR",!?(C),"PURGE ACRP FILES] option.",!!?(C),"If the purge has beenperformed for this date range, there is no way to"
.W !?(C),"identify encounters that were not transmitted due to the workload closeout",!?(C),"date.",!!?(C),"If this count exceeds 3000 and you do notbelieve that the purge has been"
.W !?(C),"performed at your site, please contact National VistA Support (NVS) for",!?(C),"assistance in retransmitting the encounters at your site."
.Q
;
;Re-flag encounters for transmission
S SDOE=0 F S SDOE=$O(^TMP("SD198",$J,SDOE)) Q:'SDOE D
.S SDDT=+^TMP("SD198",$J,SDOE)
.S SDXP=$$CRTXMIT^SCDXFU01(SDOE,,SDDT)
.Q:SDXP'>0
.D STREEVNT^SCDXFU01(SDXP,0)
.D XMITFLAG^SCDXFU01(SDXP,0)
.Q
;
;Report the results
D HDR S SDTIT1="This process re-flagged "_SDCT_" encounter"_$S(SDCT=1:"",1:"s")_" for transmission." W !!?(IOM-$L(SDTIT1)\2),SDTIT1
;
EXIT K %,%H,%I,SDCT,SDDT,SDFORCE,SDLINE,SDOE,SDOE0,SDPAGE,SDPNOW,SDSTAT,SDTIT,SDTIT1,SDXP,X,Y,^TMP("SD198",$J) Q
;
FORCE ;Force the reflagging of all applicable encounters
;
; CAUTION!!! Do not use this entry point unless you are SURE that
; the site has not purged transmission data for this
; date range!
;
S SDFORCE=1 G EN
;
HDR ;Print report header
W:SDPAGE>1 @IOF
W SDLINE,!?(IOM-$L(SDTIT)\2),SDTIT,!,SDLINE,!,"Date printed:",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD53198P 6654 printed Sep 23, 2025@20:21:25 Page 2
SD53198P ;BP-CIOFO/NDH - POST INSTALL SD*5.3*198 ; 20 Aug 99 09:00 AM
+1 ;;5.3;Scheduling;**198**;Aug 13 1993
+2 ;
SEED ;Seed NPCD ENCOUNTER MONTH multiple (#404.9171) of the SCHEDULING
+1 ; PARAMETER file (#404.91) with workload close-out dates for FY2000
+2 ;
+3 ;Declare variables
+4 NEW XPDIDTOT,LINE,DATES,WLMONTH,DBCLOSE,WLCLOSE,TMP
+5 ;Print header
+6 DO BMES^XPDUTL(">>> Storing revised close-out dates for Fiscal Year 1999")
+7 SET TMP=$$INSERT^SCDXUTL1("Workload","",7)
+8 SET TMP=$$INSERT^SCDXUTL1("Database",TMP,27)
+9 SET TMP=$$INSERT^SCDXUTL1("Workload",TMP,47)
+10 DO BMES^XPDUTL(TMP)
+11 SET TMP=$$INSERT^SCDXUTL1("Occured In","",6)
+12 SET TMP=$$INSERT^SCDXUTL1("Close-Out",TMP,27)
+13 SET TMP=$$INSERT^SCDXUTL1("Close-Out",TMP,47)
+14 DO MES^XPDUTL(TMP)
+15 SET TMP=$$INSERT^SCDXUTL1("------------","",5)
+16 SET TMP=$$INSERT^SCDXUTL1("------------",TMP,25)
+17 SET TMP=$$INSERT^SCDXUTL1("------------",TMP,45)
+18 DO MES^XPDUTL(TMP)
+19 ;Loop through list of dates
+20 SET XPDIDTOT=6
+21 FOR LINE=2:1:7
SET TMP=$TEXT(FY99+LINE)
SET DATES=$PIECE(TMP,";",3)
if (DATES="")
QUIT
Begin DoDot:1
+22 ;Break out info
+23 SET WLMONTH=$PIECE(DATES,"^",1)
+24 SET DBCLOSE=$PIECE(DATES,"^",2)
+25 SET WLCLOSE=$PIECE(DATES,"^",3)
+26 ;Print close-out info
+27 SET TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(WLMONTH,"1D"),"",7)
+28 SET TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(DBCLOSE,"1D"),TMP,25)
+29 SET TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(WLCLOSE,"1D"),TMP,45)
+30 DO MES^XPDUTL(TMP)
+31 ;Store close-out info
+32 SET TMP=$$AECLOSE^SCDXFU04(WLMONTH,DBCLOSE,WLCLOSE)
+33 ;Write error message if datebase or workload dates not updated
+34 IF TMP<0
DO MES^XPDUTL(" >>>>Could not update closeout dates for above month.")
+35 ;If KIDS install, show progress through status bar
+36 if ($GET(XPDNM)'="")
DO UPDATE^XPDID(LINE-1)
End DoDot:1
+37 DO BMES^XPDUTL("")
+38 ;Print header
+39 DO BMES^XPDUTL(">>> Storing close-out dates for Fiscal Year 2000")
+40 SET TMP=$$INSERT^SCDXUTL1("Workload","",7)
+41 SET TMP=$$INSERT^SCDXUTL1("Database",TMP,27)
+42 SET TMP=$$INSERT^SCDXUTL1("Workload",TMP,47)
+43 DO BMES^XPDUTL(TMP)
+44 SET TMP=$$INSERT^SCDXUTL1("Occured In","",6)
+45 SET TMP=$$INSERT^SCDXUTL1("Close-Out",TMP,27)
+46 SET TMP=$$INSERT^SCDXUTL1("Close-Out",TMP,47)
+47 DO MES^XPDUTL(TMP)
+48 SET TMP=$$INSERT^SCDXUTL1("------------","",5)
+49 SET TMP=$$INSERT^SCDXUTL1("------------",TMP,25)
+50 SET TMP=$$INSERT^SCDXUTL1("------------",TMP,45)
+51 DO MES^XPDUTL(TMP)
+52 ;Loop through list of dates
+53 SET XPDIDTOT=12
+54 FOR LINE=2:1:13
SET TMP=$TEXT(FY00+LINE)
SET DATES=$PIECE(TMP,";",3)
if (DATES="")
QUIT
Begin DoDot:1
+55 ;Break out info
+56 SET WLMONTH=$PIECE(DATES,"^",1)
+57 SET DBCLOSE=$PIECE(DATES,"^",2)
+58 SET WLCLOSE=$PIECE(DATES,"^",3)
+59 ;Print close-out info
+60 SET TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(WLMONTH,"1D"),"",7)
+61 SET TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(DBCLOSE,"1D"),TMP,25)
+62 SET TMP=$$INSERT^SCDXUTL1($$FMTE^XLFDT(WLCLOSE,"1D"),TMP,45)
+63 DO MES^XPDUTL(TMP)
+64 ;Store close-out info
+65 SET TMP=$$AECLOSE^SCDXFU04(WLMONTH,DBCLOSE,WLCLOSE)
+66 ;Write error message if datebase or workload dates not updated
+67 IF TMP<0
DO MES^XPDUTL(" >>>>Could not update closeout dates for above month.")
+68 ;If KIDS install, show progress through status bar
+69 if ($GET(XPDNM)'="")
DO UPDATE^XPDID(LINE-1)
End DoDot:1
+70 DO BMES^XPDUTL("")
+71 QUIT
+72 ;
FY99 ;Revised Close-out dates for fiscal year 2000
+1 ; Month ^ Database Close-Out ^ Workload Close-Out
+2 ;;2981000^2991015^2981106
+3 ;;2981100^2991015^2981211
+4 ;;2981200^2991015^2990108
+5 ;;2990100^2991015^2990212
+6 ;;2990200^2991015^2990312
+7 ;;2990300^2991015^2990409
+8 ;
FY00 ;Revised Close-out dates for fiscal year 2000
+1 ; Month ^ Database Close-Out ^ Workload Close-Out
+2 ;;2991000^3000414^2991112
+3 ;;2991100^3000414^2991210
+4 ;;2991200^3000414^3000107
+5 ;;3000100^3000414^3000211
+6 ;;3000200^3000414^3000310
+7 ;;3000300^3000414^3000407
+8 ;;3000400^3001013^3000512
+9 ;;3000500^3001013^3000609
+10 ;;3000600^3001013^3000707
+11 ;;3000700^3001013^3000811
+12 ;;3000800^3001013^3000908
+13 ;;3000900^3001013^3001006
+14 ;
+15 ; End Part One -
QUIT
+16 ; Mark unsent FY1999 Q1 & Q2 NPCDB activity for transmission
EN IF DT>2991015
WRITE !!,$CHAR(7),"It is too late to run this utility!"
QUIT
+1 SET SDSTAT=$ORDER(^SD(409.63,"B","CHECKED OUT",0))
IF 'SDSTAT
WRITE !!,"CHECKED OUT encounter status could not be identified!"
KILL SDSTAT
QUIT
+2 NEW ZTSAVE
SET ZTSAVE("SDSTAT")=""
SET ZTSAVE("SDFORCE")=""
+3 WRITE !
DO EN^XUTMDEVQ("START^SD53198P","Re-flag NPCDB activity",.ZTSAVE)
QUIT
+4 ;
START ;Search for activity to re-flag for transmission
+1 KILL ^TMP("SD198",$JOB)
+2 SET SDLINE=""
SET $PIECE(SDLINE,"-",(IOM+1))=""
+3 SET SDTIT="<*> RE-FLAG UNSENT FY1999 Q1 & Q2 NPCDB ACTIVITY FOR TRANSMISSION <*>"
+4 SET SDPAGE=1
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET SDPNOW=Y
+5 SET SDDT=2981000
+6 FOR
SET SDDT=$ORDER(^SCE("B",SDDT))
if 'SDDT!(SDDT>2990399)
QUIT
SET SDOE=0
FOR
SET SDOE=$ORDER(^SCE("B",SDDT,SDOE))
if 'SDOE
QUIT
Begin DoDot:1
+7 SET SDOE0=$GET(^SCE(SDOE,0))
if '$LENGTH(SDOE0)
QUIT
+8 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)
IF "2^3^6"[$PIECE($$STX^SCRPW8(SDOE,SDOE0),U)
Begin DoDot:2
+9 SET ^TMP("SD198",$JOB,SDOE)=SDOE0
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 SET (SDOE,SDCT)=0
FOR
SET SDOE=$ORDER(^TMP("SD198",$JOB,SDOE))
if 'SDOE
QUIT
SET SDCT=SDCT+1
+13 ;
+14 ;Too many to send!
+15 IF '$GET(SDFORCE)
IF SDCT>3000
Begin DoDot:1
+16 DO HDR
NEW C
SET C=(IOM-80\2)
if C<0
SET C=0
+17 WRITE !!?(C),"This process found ",SDCT," encounters that appear not to have been",!?(C),"transmitted. This may be due to transmission data being purgedat this site"
+18 WRITE !?(C),"through the use of the 'Purge Ambulatory Care Reporting files' [SCDX AMBCAR",!?(C),"PURGE ACRP FILES] option.",!!?(C),"If the purge has beenperformed for this date range, there is no way to"
+19 WRITE !?(C),"identify encounters that were not transmitted due to the workload closeout",!?(C),"date.",!!?(C),"If this count exceeds 3000 and you do notbelieve that the purge has been"
+20 WRITE !?(C),"performed at your site, please contact National VistA Support (NVS) for",!?(C),"assistance in retransmitting the encounters at your site."
+21 QUIT
End DoDot:1
GOTO EXIT
+22 ;
+23 ;Re-flag encounters for transmission
+24 SET SDOE=0
FOR
SET SDOE=$ORDER(^TMP("SD198",$JOB,SDOE))
if 'SDOE
QUIT
Begin DoDot:1
+25 SET SDDT=+^TMP("SD198",$JOB,SDOE)
+26 SET SDXP=$$CRTXMIT^SCDXFU01(SDOE,,SDDT)
+27 if SDXP'>0
QUIT
+28 DO STREEVNT^SCDXFU01(SDXP,0)
+29 DO XMITFLAG^SCDXFU01(SDXP,0)
+30 QUIT
End DoDot:1
+31 ;
+32 ;Report the results
+33 DO HDR
SET SDTIT1="This process re-flagged "_SDCT_" encounter"_$SELECT(SDCT=1:"",1:"s")_" for transmission."
WRITE !!?(IOM-$LENGTH(SDTIT1)\2),SDTIT1
+34 ;
EXIT KILL %,%H,%I,SDCT,SDDT,SDFORCE,SDLINE,SDOE,SDOE0,SDPAGE,SDPNOW,SDSTAT,SDTIT,SDTIT1,SDXP,X,Y,^TMP("SD198",$JOB)
QUIT
+1 ;
FORCE ;Force the reflagging of all applicable encounters
+1 ;
+2 ; CAUTION!!! Do not use this entry point unless you are SURE that
+3 ; the site has not purged transmission data for this
+4 ; date range!
+5 ;
+6 SET SDFORCE=1
GOTO EN
+7 ;
HDR ;Print report header
+1 if SDPAGE>1
WRITE @IOF
+2 WRITE SDLINE,!?(IOM-$LENGTH(SDTIT)\2),SDTIT,!,SDLINE,!,"Date printed:",SDPNOW,?(IOM-6-$LENGTH(SDPAGE)),"Page: ",SDPAGE,!,SDLINE
SET SDPAGE=SDPAGE+1
QUIT
