source: WorldVistAEHR/trunk/r/HOSPITAL_BASED_HOME_CARE-HBH/HBHCUTL1.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.5 KB
RevLine 
[613]1HBHCUTL1 ; LR VAMC(IRMS)/MJT-HBHC Utility module, Entry points: ENDRPT, END132, FORMMSG, BIRTHYR, SEXRACE ;2/5/98 15:19
2 ;;1.0;HOSPITAL BASED HOME CARE;**1,2,6,9,19**;NOV 01, 1993
3ENDRPT ; Print end of report message
4 W !!?28,"==== End of Report ===="
5 Q
6END132 ; Print end of report message for 132 column report
7 W !!?54,"==== End of Report ===="
8 Q
9FORMMSG ; Process Form 3/4/5 Transmit Status fields
10 W *7,!!,"Transmit Status Flag must be reset before editing this record is allowed."
11 I $P(^HBHC(631.9,1,0),U,5)="" W !!,"*** NOTICE: Hospital Number is missing from System Parameter file (#631.9).",!,"Due to automatic Form 6 Correction Record generation, Transmit Status Flag"
12 I $P(^HBHC(631.9,1,0),U,5)="" W !,"CANNOT be reset without this information. Contact IRM to enter this",!,"information using FileMan.",! S HBHCNHSP=1 H 10 Q
13 W !!,"Do you wish to reset the Flag" S %=2 D YN^DICN W ! I %=0 W !,"A 'Yes' response will reset the Transmit Status Flag field data. A 'No'",!,"response will return you to the menu without resetting the Transmit",!,"Status Flag.",!! G FORMMSG
14 S HBHCPRCT=%
15 I %'=1 S:HBHCFORM=4 Y=0 Q
16 S HBHCFILE=$S(HBHCFORM=4:632,1:631),HBHCNODE=$S(HBHCFORM=4:0,1:1),HBHCPC1=$S(HBHCFORM=3:17,HBHCFORM=4:8,1:18),HBHCPC2=$S(HBHCFORM=3:25,HBHCFORM=4:12,1:27),HBHCPC3=$S(HBHCFORM=3:26,HBHCFORM=4:13,1:28)
17 S HBHCXREF=$S(HBHCFORM=3:"AE",HBHCFORM=4:"AC",1:"AF"),HBHCSTAT=$S(HBHCFORM=3:$P(^HBHC(HBHCFILE,HBHCDFN,HBHCNODE),U,17),HBHCFORM=5:$P(^HBHC(HBHCFILE,HBHCDFN,HBHCNODE),U,18),1:$P(^HBHC(HBHCFILE,HBHCDFN,HBHCNODE),U,8))
18 D NOW^%DTC S HBHCNOW=$E(%,1,12)
19 K:HBHCSTAT]"" ^HBHC(HBHCFILE,HBHCXREF,HBHCSTAT,HBHCDFN)
20 L +^HBHC(HBHCFILE,HBHCDFN,HBHCNODE)
21 S $P(^HBHC(HBHCFILE,HBHCDFN,HBHCNODE),U,HBHCPC1)="N",^HBHC(HBHCFILE,HBHCXREF,"N",HBHCDFN)="",$P(^HBHC(HBHCFILE,HBHCDFN,HBHCNODE),U,HBHCPC2)=HBHCNOW,$P(^HBHC(HBHCFILE,HBHCDFN,HBHCNODE),U,HBHCPC3)=DUZ
22 I (HBHCFORM=3)&($P(^HBHC(HBHCFILE,HBHCDFN,0),U,40)]"") S HBHC5XMT=$P(^HBHC(HBHCFILE,HBHCDFN,HBHCNODE),U,18) K:HBHC5XMT]"" ^HBHC(HBHCFILE,"AF",HBHC5XMT,HBHCDFN) S $P(^HBHC(HBHCFILE,HBHCDFN,HBHCNODE),U,18)="N",^HBHC(HBHCFILE,"AF","N",HBHCDFN)=""
23 I HBHCFORM=5 S HBHC3XMT=$P(^HBHC(HBHCFILE,HBHCDFN,HBHCNODE),U,17) K:HBHC3XMT]"" ^HBHC(HBHCFILE,"AE",HBHC3XMT,HBHCDFN) S $P(^HBHC(HBHCFILE,HBHCDFN,HBHCNODE),U,17)="N",^HBHC(HBHCFILE,"AE","N",HBHCDFN)=""
24 L -^HBHC(HBHCFILE,HBHCDFN,HBHCNODE)
25 D:HBHCFORM'=4 SETNODE
26EXIT ; Exit FORMMSG module
27 K HBHCADDT,HBHCDPT0,HBHCDSDT,HBHCFILE,HBHCHOSP,HBHCINFO,HBHCLNTH,HBHCNAME,HBHCNDX1,HBHCNODE,HBHCNOW,HBHCPC1,HBHCPC2,HBHCPC3,HBHCREC,HBHCSP4,HBHCSP8,HBHCSP86,HBHCSTAT,HBHCXREF,HBHC3XMT,HBHC5XMT
28 Q
29SETNODE ; Set node in ^HBHC(634.4) (Form 6 Corrections file)
30 S $P(HBHCSP4," ",5)="",$P(HBHCSP8," ",9)="",$P(HBHCSP86," ",87)="",HBHCLNTH=30
31 L +^HBHC(634.4,0) S HBHCNDX1=$P(^HBHC(634.4,0),U,3)+1,$P(^HBHC(634.4,0),U,3)=HBHCNDX1,$P(^HBHC(634.4,0),U,4)=$P(^HBHC(634.4,0),U,4)+1 L -^HBHC(634.4,0)
32 S HBHCINFO=^HBHC(HBHCFILE,HBHCDFN,0),HBHCDPT0=^DPT(HBHCDPT,0)
33 S HBHCADDT=$S($P(HBHCINFO,U,18)]"":$E($P(HBHCINFO,U,18),4,5)_$E($P(HBHCINFO,U,18),6,7)_(1700+$E($P(HBHCINFO,U,18),1,3)),1:HBHCSP8)
34 S HBHCDSDT=$S($P(HBHCINFO,U,40)]"":$E($P(HBHCINFO,U,40),4,5)_$E($P(HBHCINFO,U,40),6,7)_(1700+$E($P(HBHCINFO,U,40),1,3)),1:HBHCSP8)
35 S HBHCNAME=$P(HBHCDPT0,U) S:$L(HBHCNAME)<HBHCLNTH HBHCNAME=HBHCNAME_$J("",HBHCLNTH-$L(HBHCNAME))
36 S HBHCHOSP=$P($G(^DIC(4,$P(^HBHC(631.9,1,0),U,5),99)),U) S:$L(HBHCHOSP)'=7 HBHCHOSP=HBHCHOSP_$E(HBHCSP4,1,(7-($L(HBHCHOSP))))
37 S HBHCREC=6_HBHCHOSP_$P(HBHCDPT0,U,9)_HBHCADDT_HBHCNAME_HBHCDSDT_2_HBHCSP86
38 S ^HBHC(634.4,HBHCNDX1,0)=HBHCREC,^HBHC(634.4,"B",$E(HBHCREC,1,30),HBHCNDX1)=""
39 Q
40BIRTHYR ; Birth year field display during Evaluation/Admission Data Entry
41 S HBHCDPT0=^DPT(HBHCDPT,0)
42 W !!,"BIRTH YEAR: ",$S($P(HBHCDPT0,U,3):1700+$E($P(HBHCDPT0,U,3),1,3),1:"0000"),*7 D MASMSG
43 Q
44SEXRACE ; Sex & Race fields display during Evaluation/Admission Data Entry
45 S HBHCDPT0=^DPT(HBHCDPT,0),HBHCSEX=$P(HBHCDPT0,U,2)
46 W !!,"SEX: ",$S(HBHCSEX="M":"Male (1)",1:"Female (2)"),*7 D MASMSG
47 ; Obsolete with Race/Ethnicity Info Jan 2003 mandate; commented out historical reference mjt
48 ; ,HBHCRACE=$S($P(HBHCDPT0,U,6)]"":$P(^DIC(10,$P(HBHCDPT0,U,6),0),U,2),1:"")
49 ;W !,"RACE: ",$S(HBHCRACE=4:"Black (2)",HBHCRACE=3:"American Indian/Alaskan Native (4)",HBHCRACE=6:"White (1)",(HBHCRACE=1)!(HBHCRACE=2):"Hispanic Origin (3)",HBHCRACE=5:"Asian/Pacific Islander (5)",1:"Not Determined (9)")
50 ; Field retained until VA Form 10-0014 modified to remove field mjt
51 W !,"RACE: Obsolete Field Jan 2003",!
52 K HBHCDPT0,HBHCSEX
53 Q
54MASMSG ; MAS message for BIRTHYR & SEX modules
55 W !?18,"*** Contact MAS if value is incorrect. ***",!
56 Q
Note: See TracBrowser for help on using the repository browser.