HBHCPS24 ; LR VAMC(IRMS)/MJT-HBHC HBH*1*24 Post Install Routine to force 1 last transmission of 150 character transmission records before length of transmit record changes to 200 characters ; Mar 2008
;;1.0;HOSPITAL BASED HOME CARE;**24**;NOV 01, 1993;Build 201
; routine calls HOSP^HBHCUTL1
S HBHC=$S($$PROD^XUPROD(1):"PRODUCTION",1:"TEST")
G:HBHC="TEST" EXIT
; Do 'build'
S HBHCLSDT=DT
D ^HBHCAPPT,^HBHCXMC,^HBHCXMA,^HBHCXMV,^HBHCXMD
; Do Cleanup modules
D ADM,VISIT,DC,MFH
; Transmit
S $P(^HBHC(631.9,1,0),U,6)=1
K XMDUZ,XMY,XMZ,%DT,^TMP("HBHC",$J)
N DIFROM
D HOSP^HBHCUTL1
S X="T" D ^%DT S HBHCDT=Y,HBHCDATE=$E(HBHCDT,4,5)_"/"_$E(HBHCDT,6,7)_"/"_$E(HBHCDT,2,3)
S (HBHCCNT,HBHCFLG,HBHCNODE)=0,HBHCMSG=1
F S HBHCNODE=$O(^HBHC(634,HBHCNODE)) D:(HBHCCNT>99)!(HBHCNODE'>0) MAIL Q:HBHCNODE'>0 S HBHCCNT=HBHCCNT+1,HBHCINFO=^HBHC(634,HBHCNODE,0),^TMP("HBHC",$J,HBHCMSG,HBHCNODE,0)=HBHCINFO D HISTORY
CLEANUP ; Cleanup Transmit History (HBHC(634.6)) to maintain maximum of last 12 transmit batches
S (HBHCTOT,HBHCDATE)=0 F S HBHCDATE=$O(^HBHC(634.6,"C",HBHCDATE)) Q:HBHCDATE'>0 S HBHCTOT=HBHCTOT+1 S:HBHCTOT=1 HBHCDAT=HBHCDATE
I HBHCTOT>12 S DIK="^HBHC(634.6,",DA="" F S DA=$O(^HBHC(634.6,"C",HBHCDAT,DA)) Q:DA'>0 D ^DIK
; Turn Off Transmission in Progress Flag
S $P(^HBHC(631.9,1,0),U,6)=""
EXIT ; Exit module
D ^%ZISC
K HBHC,HBHCDIR,HBHCLSDT
K DA,DIC,DIE,DIK,DR,HBHCCNT,HBHCDAT,HBHCDATE,HBHCDT,HBHCFLG,HBHCHOSP,HBHCINFO,HBHCMSG,HBHCNODE,HBHCPRTR,HBHCTOT,HBHCZ,XMSUB,XMTEXT,XMY,XMZ,X,Y,%,%DT,^TMP("HBHC",$J)
Q
ADM ; Clean up Admission Error file (#634.1)
I $D(^HBHC(634.1,"B")) K ^HBHC(634.1) S ^HBHC(634.1,0)="HBHC EVALUATION/ADMISSION ERROR(S)^634.1"
Q
VISIT ; Clean up Visit Error file (#634.2)
I $D(^HBHC(634.2,"B")) K ^HBHC(634.2) S ^HBHC(634.2,0)="HBHC VISIT ERROR(S)^634.2P"
Q
DC ; Clean up Discharge Error file (#634.3)
I $D(^HBHC(634.3,"B")) K ^HBHC(634.3) S ^HBHC(634.3,0)="HBHC DISCHARGE ERROR(S)^634.3"
Q
MFH ; Clean up MFH Error file (#634.7)
I $D(^HBHC(634.7,"B")) K ^HBHC(634.7) S ^HBHC(634.7,0)="HBHC MEDICAL FOSTER HOME ERROR(S)^634.7P"
Q
MAIL ; Send mail message
S XMSUB="HBHC Site: "_$S($P(^HBHC(631.9,1,0),U,5)]"":$E(HBHCHOSP,1,3),1:"")_" Message: "_HBHCMSG_" "_HBHCDATE_" Transmission",XMTEXT="^TMP(""HBHC"",$J,HBHCMSG,",XMY("XXX@Q-HBH.DOMAIN.EXT")=""
D ^XMD
S HBHCMSG=HBHCMSG+1,HBHCCNT=0
LOOP ; Loop thru ^HBHC(631,"AE") (Form 3 Transmit Flag), ^HBHC(631,"AF") (Form 5 Transmit Flag), & ^HBHC(632,"AC") (Form 4 Transmit Flag) cross-refs to set batch initial MM message number & mailman message date fields in ^HBHC(631/632)
; also loop thru ^HBHC(633.2,"AC") (Form 7 Transmit Flag)
Q:HBHCFLG
S DIE="^HBHC(631,"
S DR="71///T;74///^S X=XMZ;75///^S X=HBHCDT",DA="" F S DA=$O(^HBHC(631,"AE","F",DA)) Q:DA="" D ^DIE
S DR="72///T;77///^S X=XMZ;78///^S X=HBHCDT",DA="" F S DA=$O(^HBHC(631,"AF","F",DA)) Q:DA="" D ^DIE
S DIE="^HBHC(632,",DR="7///T;9///^S X=XMZ;10///^S X=HBHCDT",DA="" F S DA=$O(^HBHC(632,"AC","F",DA)) Q:DA="" D ^DIE
; Only update if Sanctioned MFH site
I $P($G(^HBHC(631.9,1,0)),U,9)]"" S DIE="^HBHC(633.2,",DR="27///T;29///^S X=XMZ;30///^S X=HBHCDT",DA="" F S DA=$O(^HBHC(633.2,"AC","F",DA)) Q:DA="" D ^DIE
; Set Last Mail Message Date in System Parameters file
S $P(^HBHC(631.9,1,0),U,2)=HBHCDT
S HBHCFLG=1
Q
HISTORY ; Update HBHC(634.6 Transmit History file
K DD,DO S DIC="^HBHC(634.6,",DIC(0)="L",DIC("DR")="1///^S X=HBHCDT",X=HBHCINFO D FILE^DICN K DO
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCPS24 3514 printed Dec 13, 2024@01:58:11 Page 2
HBHCPS24 ; LR VAMC(IRMS)/MJT-HBHC HBH*1*24 Post Install Routine to force 1 last transmission of 150 character transmission records before length of transmit record changes to 200 characters ; Mar 2008
+1 ;;1.0;HOSPITAL BASED HOME CARE;**24**;NOV 01, 1993;Build 201
+2 ; routine calls HOSP^HBHCUTL1
+3 SET HBHC=$SELECT($$PROD^XUPROD(1):"PRODUCTION",1:"TEST")
+4 if HBHC="TEST"
GOTO EXIT
+5 ; Do 'build'
+6 SET HBHCLSDT=DT
+7 DO ^HBHCAPPT
DO ^HBHCXMC
DO ^HBHCXMA
DO ^HBHCXMV
DO ^HBHCXMD
+8 ; Do Cleanup modules
+9 DO ADM
DO VISIT
DO DC
DO MFH
+10 ; Transmit
+11 SET $PIECE(^HBHC(631.9,1,0),U,6)=1
+12 KILL XMDUZ,XMY,XMZ,%DT,^TMP("HBHC",$JOB)
+13 NEW DIFROM
+14 DO HOSP^HBHCUTL1
+15 SET X="T"
DO ^%DT
SET HBHCDT=Y
SET HBHCDATE=$EXTRACT(HBHCDT,4,5)_"/"_$EXTRACT(HBHCDT,6,7)_"/"_$EXTRACT(HBHCDT,2,3)
+16 SET (HBHCCNT,HBHCFLG,HBHCNODE)=0
SET HBHCMSG=1
+17 FOR
SET HBHCNODE=$ORDER(^HBHC(634,HBHCNODE))
if (HBHCCNT>99)!(HBHCNODE'>0)
DO MAIL
if HBHCNODE'>0
QUIT
SET HBHCCNT=HBHCCNT+1
SET HBHCINFO=^HBHC(634,HBHCNODE,0)
SET ^TMP("HBHC",$JOB,HBHCMSG,HBHCNODE,0)=HBHCINFO
DO HISTORY
CLEANUP ; Cleanup Transmit History (HBHC(634.6)) to maintain maximum of last 12 transmit batches
+1 SET (HBHCTOT,HBHCDATE)=0
FOR
SET HBHCDATE=$ORDER(^HBHC(634.6,"C",HBHCDATE))
if HBHCDATE'>0
QUIT
SET HBHCTOT=HBHCTOT+1
if HBHCTOT=1
SET HBHCDAT=HBHCDATE
+2 IF HBHCTOT>12
SET DIK="^HBHC(634.6,"
SET DA=""
FOR
SET DA=$ORDER(^HBHC(634.6,"C",HBHCDAT,DA))
if DA'>0
QUIT
DO ^DIK
+3 ; Turn Off Transmission in Progress Flag
+4 SET $PIECE(^HBHC(631.9,1,0),U,6)=""
EXIT ; Exit module
+1 DO ^%ZISC
+2 KILL HBHC,HBHCDIR,HBHCLSDT
+3 KILL DA,DIC,DIE,DIK,DR,HBHCCNT,HBHCDAT,HBHCDATE,HBHCDT,HBHCFLG,HBHCHOSP,HBHCINFO,HBHCMSG,HBHCNODE,HBHCPRTR,HBHCTOT,HBHCZ,XMSUB,XMTEXT,XMY,XMZ,X,Y,%,%DT,^TMP("HBHC",$JOB)
+4 QUIT
ADM ; Clean up Admission Error file (#634.1)
+1 IF $DATA(^HBHC(634.1,"B"))
KILL ^HBHC(634.1)
SET ^HBHC(634.1,0)="HBHC EVALUATION/ADMISSION ERROR(S)^634.1"
+2 QUIT
VISIT ; Clean up Visit Error file (#634.2)
+1 IF $DATA(^HBHC(634.2,"B"))
KILL ^HBHC(634.2)
SET ^HBHC(634.2,0)="HBHC VISIT ERROR(S)^634.2P"
+2 QUIT
DC ; Clean up Discharge Error file (#634.3)
+1 IF $DATA(^HBHC(634.3,"B"))
KILL ^HBHC(634.3)
SET ^HBHC(634.3,0)="HBHC DISCHARGE ERROR(S)^634.3"
+2 QUIT
MFH ; Clean up MFH Error file (#634.7)
+1 IF $DATA(^HBHC(634.7,"B"))
KILL ^HBHC(634.7)
SET ^HBHC(634.7,0)="HBHC MEDICAL FOSTER HOME ERROR(S)^634.7P"
+2 QUIT
MAIL ; Send mail message
+1 SET XMSUB="HBHC Site: "_$SELECT($PIECE(^HBHC(631.9,1,0),U,5)]"":$EXTRACT(HBHCHOSP,1,3),1:"")_" Message: "_HBHCMSG_" "_HBHCDATE_" Transmission"
SET XMTEXT="^TMP(""HBHC"",$J,HBHCMSG,"
SET XMY("XXX@Q-HBH.DOMAIN.EXT")=""
+2 DO ^XMD
+3 SET HBHCMSG=HBHCMSG+1
SET HBHCCNT=0
LOOP ; Loop thru ^HBHC(631,"AE") (Form 3 Transmit Flag), ^HBHC(631,"AF") (Form 5 Transmit Flag), & ^HBHC(632,"AC") (Form 4 Transmit Flag) cross-refs to set batch initial MM message number & mailman message date fields in ^HBHC(631/632)
+1 ; also loop thru ^HBHC(633.2,"AC") (Form 7 Transmit Flag)
+2 if HBHCFLG
QUIT
+3 SET DIE="^HBHC(631,"
+4 SET DR="71///T;74///^S X=XMZ;75///^S X=HBHCDT"
SET DA=""
FOR
SET DA=$ORDER(^HBHC(631,"AE","F",DA))
if DA=""
QUIT
DO ^DIE
+5 SET DR="72///T;77///^S X=XMZ;78///^S X=HBHCDT"
SET DA=""
FOR
SET DA=$ORDER(^HBHC(631,"AF","F",DA))
if DA=""
QUIT
DO ^DIE
+6 SET DIE="^HBHC(632,"
SET DR="7///T;9///^S X=XMZ;10///^S X=HBHCDT"
SET DA=""
FOR
SET DA=$ORDER(^HBHC(632,"AC","F",DA))
if DA=""
QUIT
DO ^DIE
+7 ; Only update if Sanctioned MFH site
+8 IF $PIECE($GET(^HBHC(631.9,1,0)),U,9)]""
SET DIE="^HBHC(633.2,"
SET DR="27///T;29///^S X=XMZ;30///^S X=HBHCDT"
SET DA=""
FOR
SET DA=$ORDER(^HBHC(633.2,"AC","F",DA))
if DA=""
QUIT
DO ^DIE
+9 ; Set Last Mail Message Date in System Parameters file
+10 SET $PIECE(^HBHC(631.9,1,0),U,2)=HBHCDT
+11 SET HBHCFLG=1
+12 QUIT
HISTORY ; Update HBHC(634.6 Transmit History file
+1 KILL DD,DO
SET DIC="^HBHC(634.6,"
SET DIC(0)="L"
SET DIC("DR")="1///^S X=HBHCDT"
SET X=HBHCINFO
DO FILE^DICN
KILL DO
+2 QUIT
