DVBANDCU ;ALB/GTS - Clean-up routine 7131 ASIH notice of discharges; 12 Mar 96 @ 14:00pm [3/12/96 1:45pm]
;;2/7;AMIE;**5**;Mar 12, 1996
;
TEXT ;;
;;This routine will walk through the FORM 7131 file (#396) and cleanup
;;any ASIH admission dates.
;;
;;Once the process has completed, a MailMan message will be
;;delivered to the person installing the patch. The message
;;will list 7131 requests that were cleaned up and Notices of
;;Discharge generated. If Notices of Discharge were generated,
;;it is recommended you forward this message to those Regional
;;Office AMIE users so they will be aware of the changes to the
;;data in the AMIE system.
;;
;;
;;QUIT
;
STARTPT ;
S (LNI,LNX)=""
D MES^XPDUTL(" "),MES^XPDUTL(" ")
F LNI=1:1 S LNX=$P($T(TEXT+LNI),";;",2) Q:(LNX="QUIT") DO
.S:LNX="" LNX=" "
.D MES^XPDUTL(LNX)
D CLN7131
K LNI,LNX
Q
;
CLN7131 ;** Init process, call correction tag and send mail msg
S VAFEDXCT=0
D LINE("Results of AMIE 7131 ASIH clean-up at station "_$$SITE^VASITE())
D LINE("")
D LINE("Start time: "_$$NOW^XLFDT()),LINE("Job Number: "_$J)
D LINE(""),LINE("")
D LINE("This message was generated as part of the clean up performed with")
D LINE(" the installation of patch DVBA*2.7*5.")
D LINE("")
D LINE("IRM STAFF INFORMATION FOLLOWS: ")
D LINE("The following is a list of 7131 requests entered for an ASIH")
D LINE(" Admission date. The Admission Date field (#3) was changed so")
D LINE(" the time stamp no longer indicates ASIH."),LINE("")
D LINE("Only Regional Office Staff need be concerned with this.")
D LINE("")
D LINE("REGIONAL OFFICE STAFF INFORMATION FOLLOWS: ")
D LINE("R/O Staff, If you are adjudicating the claim of a veteran listed here,")
D LINE(" be aware that Notices of Discharge generated for the admission date noted")
D LINE(" may indicate discharge to another VA Facility.")
D LINE("Check the veteran's claim folder for determination of action necessary.")
D LINE(""),LINE("")
D CORRECT ;** Correct 7131 ASIH records
D LINE("")
D LINE("End time: "_$$NOW^XLFDT())
D MAIL ; mail results
Q
;
CORRECT ;** Walk 7131s, correct ASIH admit dts and gen 7132s
N CT,J,DVBARQDT,DVBAASIH,DVBAPAT,DVBADFN,DGPMDA,DGDT,TDIS
D SETXRO ;* Set RO station # array
S CT=0
S (J,DVBARQDT)=""
F S DVBARQDT=$O(^DVB(396,"G",DVBARQDT)) Q:(DVBARQDT="") DO
.F S J=$O(^DVB(396,"G",DVBARQDT,J)) Q:J="" DO
..I $D(^DVB(396,J,0)),($D(^DVB(396,J,2))) DO
...S DVBAASIH=$P(DVBARQDT,".",2)
...I ($L(DVBAASIH)>6)&($P(^DVB(396,J,2),"^",10)="A") DO
....S DVBADFN=$P(^DVB(396,J,0),"^",1)
....S DVBAPAT=$P($G(^DPT(DVBADFN,0)),"^",1)
....S:DVBAPAT="" DVBAPAT="(IRM NOTE: Bad patient name for DFN "_DVBADFN_")"
....S DFN=DVBADFN
....S VAIP("D")=DVBARQDT
....S VAIP("M")=0
....D IN5^VADPT
....S DGPMDA=VAIP(1)
....S DGDT=0
....S DGDT=VAIP(17)
....S TDIS=$P(VAIP(17,3),"^",2)
....K VAIP,DFN
....S DVBARQDT=+$E(DVBARQDT,1,14)
....S DA=J,DIE="^DVB(396,",DR="3////^S X=DVBARQDT"
....D ^DIE
....K DIE,DR,X,DA
....S Y=DVBARQDT
....X ^DD("DD")
....D LINE(" "_DVBAPAT_" 7131 for ASIH Admission Date "_Y_" corrected.")
....K Y
....D:DGDT GEN7132(DVBADFN,J,DVBARQDT,DGPMDA,TDIS)
....S CT=CT+1
D:+CT'>0 LINE("No ASIH Admission 7131s were found for your Medical Center.")
D LINE(""),LINE("")
D LINE("The number of records corrected was "_CT)
D LINE(""),LINE("")
D:+CT>0 LINE("IRM PERSONNEL: ")
D:+CT>0 LINE("Please forward this message to Regional Office personnel who use your system.")
K XRO
Q
;
SETXRO ;* Set up regional office station numbers array
N I,J
F I=0:0 S I=$O(^DVB(396.1,1,1,I)) Q:I=""!(+I=0) S J=$P(^(I,0),U,1),J=$S($D(^DIC(4,+J,99)):$P(^(99),U),1:"") I J]"" S XRO(J)=""
Q
;
GEN7132(DFN,DVBADA,ADMDT,DGPMDA,TDIS) ;* Gen Notice of Discharge (file 396.2)
;**NOTE: XRO(n) Array must be defined with N being the RO station #s
N CFLOC
S CFLOC=$P($G(^DPT(DFN,.31)),"^",4)
S:CFLOC'="" CFLOC=$S($D(^DIC(4,CFLOC,99)):$P(^DIC(4,CFLOC,99),"^",1),1:"")
Q:CFLOC="" ;QUIT:no CFLOC
I '$D(XRO(CFLOC))&(CFLOC'=376) Q ;**QUIT if RO not user at site
I CFLOC=376,TDIS["DEATH" S CFLOC=$O(XRO(0)) Q:CFLOC="" ;QUIT:no RO'S
Q:$D(^DVB(396.2,"D",ADMDT,DFN)) ;**QUIT if 7132 exists
I ($P(^DVB(396,DVBADA,0),U,5)="YES")&($P(^(0),U,9)="P") DO
.S SSN=$P($G(^DPT(DFN,0)),"^",9)
.S (DIC,DIE)="^DVB(396.2,"
.S DR="3.5///"_CFLOC_";1///"_ADMDT_";2///"_DGPMDA_";3///R"
.S DLAYGO=396.2,DIC(0)="QLM",X=""""_SSN_""""
.D ^DIC
.I +Y>0 DO
..S DA=+Y
..D ^DIE
..D LINE(" .....Notice of Discharge has been generated!")
..D LINE(""),LINE("")
.K DR,DLAYGO,DIC,DIE,X,Y,SSN
Q
;
MAIL ;** Mail Cleanup msg
N DIFROM
K XMY
S XMSUB="AMIE 7131 ASIH clean up"
S XMN=0
S XMTEXT="^TMP(""DVBA ASIH CLEANUP"",$J,"
S XMDUZ=.5,XMY(DUZ)=""
D ^XMD
D MES^XPDUTL(" "),MES^XPDUTL(" ")
D MES^XPDUTL(" ...Message has been delivered to installer!")
K VAFEDXCT,XMDUZ,XMN,XMSUB,XMTEXT,XMY,^TMP("DVBA ASIH CLEANUP",$J)
Q
;
LINE(TEXT) ; add line to array for e-mail
S VAFEDXCT=VAFEDXCT+1,^TMP("DVBA ASIH CLEANUP",$J,VAFEDXCT)=TEXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBANDCU 5151 printed Apr 09, 2024@20:44:49 Page 2
DVBANDCU ;ALB/GTS - Clean-up routine 7131 ASIH notice of discharges; 12 Mar 96 @ 14:00pm [3/12/96 1:45pm]
+1 ;;2/7;AMIE;**5**;Mar 12, 1996
+2 ;
TEXT ;;
+1 ;;This routine will walk through the FORM 7131 file (#396) and cleanup
+2 ;;any ASIH admission dates.
+3 ;;
+4 ;;Once the process has completed, a MailMan message will be
+5 ;;delivered to the person installing the patch. The message
+6 ;;will list 7131 requests that were cleaned up and Notices of
+7 ;;Discharge generated. If Notices of Discharge were generated,
+8 ;;it is recommended you forward this message to those Regional
+9 ;;Office AMIE users so they will be aware of the changes to the
+10 ;;data in the AMIE system.
+11 ;;
+12 ;;
+13 ;;QUIT
+14 ;
STARTPT ;
+1 SET (LNI,LNX)=""
+2 DO MES^XPDUTL(" ")
DO MES^XPDUTL(" ")
+3 FOR LNI=1:1
SET LNX=$PIECE($TEXT(TEXT+LNI),";;",2)
if (LNX="QUIT")
QUIT
Begin DoDot:1
+4 if LNX=""
SET LNX=" "
+5 DO MES^XPDUTL(LNX)
End DoDot:1
+6 DO CLN7131
+7 KILL LNI,LNX
+8 QUIT
+9 ;
CLN7131 ;** Init process, call correction tag and send mail msg
+1 SET VAFEDXCT=0
+2 DO LINE("Results of AMIE 7131 ASIH clean-up at station "_$$SITE^VASITE())
+3 DO LINE("")
+4 DO LINE("Start time: "_$$NOW^XLFDT())
DO LINE("Job Number: "_$JOB)
+5 DO LINE("")
DO LINE("")
+6 DO LINE("This message was generated as part of the clean up performed with")
+7 DO LINE(" the installation of patch DVBA*2.7*5.")
+8 DO LINE("")
+9 DO LINE("IRM STAFF INFORMATION FOLLOWS: ")
+10 DO LINE("The following is a list of 7131 requests entered for an ASIH")
+11 DO LINE(" Admission date. The Admission Date field (#3) was changed so")
+12 DO LINE(" the time stamp no longer indicates ASIH.")
DO LINE("")
+13 DO LINE("Only Regional Office Staff need be concerned with this.")
+14 DO LINE("")
+15 DO LINE("REGIONAL OFFICE STAFF INFORMATION FOLLOWS: ")
+16 DO LINE("R/O Staff, If you are adjudicating the claim of a veteran listed here,")
+17 DO LINE(" be aware that Notices of Discharge generated for the admission date noted")
+18 DO LINE(" may indicate discharge to another VA Facility.")
+19 DO LINE("Check the veteran's claim folder for determination of action necessary.")
+20 DO LINE("")
DO LINE("")
+21 ;** Correct 7131 ASIH records
DO CORRECT
+22 DO LINE("")
+23 DO LINE("End time: "_$$NOW^XLFDT())
+24 ; mail results
DO MAIL
+25 QUIT
+26 ;
CORRECT ;** Walk 7131s, correct ASIH admit dts and gen 7132s
+1 NEW CT,J,DVBARQDT,DVBAASIH,DVBAPAT,DVBADFN,DGPMDA,DGDT,TDIS
+2 ;* Set RO station # array
DO SETXRO
+3 SET CT=0
+4 SET (J,DVBARQDT)=""
+5 FOR
SET DVBARQDT=$ORDER(^DVB(396,"G",DVBARQDT))
if (DVBARQDT="")
QUIT
Begin DoDot:1
+6 FOR
SET J=$ORDER(^DVB(396,"G",DVBARQDT,J))
if J=""
QUIT
Begin DoDot:2
+7 IF $DATA(^DVB(396,J,0))
IF ($DATA(^DVB(396,J,2)))
Begin DoDot:3
+8 SET DVBAASIH=$PIECE(DVBARQDT,".",2)
+9 IF ($LENGTH(DVBAASIH)>6)&($PIECE(^DVB(396,J,2),"^",10)="A")
Begin DoDot:4
+10 SET DVBADFN=$PIECE(^DVB(396,J,0),"^",1)
+11 SET DVBAPAT=$PIECE($GET(^DPT(DVBADFN,0)),"^",1)
+12 if DVBAPAT=""
SET DVBAPAT="(IRM NOTE: Bad patient name for DFN "_DVBADFN_")"
+13 SET DFN=DVBADFN
+14 SET VAIP("D")=DVBARQDT
+15 SET VAIP("M")=0
+16 DO IN5^VADPT
+17 SET DGPMDA=VAIP(1)
+18 SET DGDT=0
+19 SET DGDT=VAIP(17)
+20 SET TDIS=$PIECE(VAIP(17,3),"^",2)
+21 KILL VAIP,DFN
+22 SET DVBARQDT=+$EXTRACT(DVBARQDT,1,14)
+23 SET DA=J
SET DIE="^DVB(396,"
SET DR="3////^S X=DVBARQDT"
+24 DO ^DIE
+25 KILL DIE,DR,X,DA
+26 SET Y=DVBARQDT
+27 XECUTE ^DD("DD")
+28 DO LINE(" "_DVBAPAT_" 7131 for ASIH Admission Date "_Y_" corrected.")
+29 KILL Y
+30 if DGDT
DO GEN7132(DVBADFN,J,DVBARQDT,DGPMDA,TDIS)
+31 SET CT=CT+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+32 if +CT'>0
DO LINE("No ASIH Admission 7131s were found for your Medical Center.")
+33 DO LINE("")
DO LINE("")
+34 DO LINE("The number of records corrected was "_CT)
+35 DO LINE("")
DO LINE("")
+36 if +CT>0
DO LINE("IRM PERSONNEL: ")
+37 if +CT>0
DO LINE("Please forward this message to Regional Office personnel who use your system.")
+38 KILL XRO
+39 QUIT
+40 ;
SETXRO ;* Set up regional office station numbers array
+1 NEW I,J
+2 FOR I=0:0
SET I=$ORDER(^DVB(396.1,1,1,I))
if I=""!(+I=0)
QUIT
SET J=$PIECE(^(I,0),U,1)
SET J=$SELECT($DATA(^DIC(4,+J,99)):$PIECE(^(99),U),1:"")
IF J]""
SET XRO(J)=""
+3 QUIT
+4 ;
GEN7132(DFN,DVBADA,ADMDT,DGPMDA,TDIS) ;* Gen Notice of Discharge (file 396.2)
+1 ;**NOTE: XRO(n) Array must be defined with N being the RO station #s
+2 NEW CFLOC
+3 SET CFLOC=$PIECE($GET(^DPT(DFN,.31)),"^",4)
+4 if CFLOC'=""
SET CFLOC=$SELECT($DATA(^DIC(4,CFLOC,99)):$PIECE(^DIC(4,CFLOC,99),"^",1),1:"")
+5 ;QUIT:no CFLOC
if CFLOC=""
QUIT
+6 ;**QUIT if RO not user at site
IF '$DATA(XRO(CFLOC))&(CFLOC'=376)
QUIT
+7 ;QUIT:no RO'S
IF CFLOC=376
IF TDIS["DEATH"
SET CFLOC=$ORDER(XRO(0))
if CFLOC=""
QUIT
+8 ;**QUIT if 7132 exists
if $DATA(^DVB(396.2,"D",ADMDT,DFN))
QUIT
+9 IF ($PIECE(^DVB(396,DVBADA,0),U,5)="YES")&($PIECE(^(0),U,9)="P")
Begin DoDot:1
+10 SET SSN=$PIECE($GET(^DPT(DFN,0)),"^",9)
+11 SET (DIC,DIE)="^DVB(396.2,"
+12 SET DR="3.5///"_CFLOC_";1///"_ADMDT_";2///"_DGPMDA_";3///R"
+13 SET DLAYGO=396.2
SET DIC(0)="QLM"
SET X=""""_SSN_""""
+14 DO ^DIC
+15 IF +Y>0
Begin DoDot:2
+16 SET DA=+Y
+17 DO ^DIE
+18 DO LINE(" .....Notice of Discharge has been generated!")
+19 DO LINE("")
DO LINE("")
End DoDot:2
+20 KILL DR,DLAYGO,DIC,DIE,X,Y,SSN
End DoDot:1
+21 QUIT
+22 ;
MAIL ;** Mail Cleanup msg
+1 NEW DIFROM
+2 KILL XMY
+3 SET XMSUB="AMIE 7131 ASIH clean up"
+4 SET XMN=0
+5 SET XMTEXT="^TMP(""DVBA ASIH CLEANUP"",$J,"
+6 SET XMDUZ=.5
SET XMY(DUZ)=""
+7 DO ^XMD
+8 DO MES^XPDUTL(" ")
DO MES^XPDUTL(" ")
+9 DO MES^XPDUTL(" ...Message has been delivered to installer!")
+10 KILL VAFEDXCT,XMDUZ,XMN,XMSUB,XMTEXT,XMY,^TMP("DVBA ASIH CLEANUP",$JOB)
+11 QUIT
+12 ;
LINE(TEXT) ; add line to array for e-mail
+1 SET VAFEDXCT=VAFEDXCT+1
SET ^TMP("DVBA ASIH CLEANUP",$JOB,VAFEDXCT)=TEXT
+2 QUIT
