source: WorldVistAEHR/trunk/r/HOSPITAL_BASED_HOME_CARE-HBH/HBHCUTL.m@ 949

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

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1HBHCUTL ; LR VAMC(IRMS)/MJT-HBHC Utility module, Entry points: ACTION, STATUS, START, TODAY, HDRPAGE, HDRRANGE, HDR132, HDR132NR ; Mar 2000
2 ;;1.0;HOSPITAL BASED HOME CARE;**2,6,8,16**;NOV 01, 1993
3ACTION ; Set appropriate fields/variables for Admit/Reject Action
4 K HBHCQ,HBHCKEEP
5 S HBHCY0=^HBHC(631,HBHCDFN,0)
6 S:X="" Y=$S($D(HBHCUPD):0,1:87) S:X=1 Y=18 S:X=2 HBHCQ=1
7 S HBHCAFLG=0 F HBHCI=19:1:37 Q:HBHCAFLG S:$P(HBHCY0,U,HBHCI)]"" HBHCAFLG=1
8 S HBHCRFLG=0 I ($P(HBHCY0,U,16)]"")!($P(HBHCY0,U,17)]"") S HBHCRFLG=1
9 Q:(HBHCAFLG=0)&(HBHCRFLG=0)
10 Q:(HBHCRFLG=0)&(X=1)
11 Q:(HBHCAFLG=0)&(X=2)
12 S HBHCWRD1=$S(HBHCAFLG=1:"admission",1:"rejection")
13 S HBHCWRD2=$S(X="":"to 'Delete'",X=2:"'Reject' in",1:"'Admit' in")
14 S HBHCWRD3=$S(HBHCAFLG=1:"1 for Admit",1:"2 for Reject")
15 D PROCADM I %=1 D:HBHCAFLG ADMIT S:HBHCRFLG $P(^HBHC(631,HBHCDFN,0),U,16)="",$P(^HBHC(631,HBHCDFN,0),U,17)=""
16 Q
17PROCADM ; Process 'Delete' & 'Reject' responses
18 W *7,!!,"This record contains ",HBHCWRD1," data. Are you sure you want ",HBHCWRD2," the",!,"Admit/Reject Action field ('Yes' will delete the ",HBHCWRD1," data)" S %=2 D YN^DICN
19 W ! W:%=0 !!,"Admit/Reject Action field must either contain ",HBHCWRD3," or the ",HBHCWRD1,!,"data MUST be deleted by responding 'Yes'.",!!
20 I %'=1 S Y=$S($D(HBHCUPD):0,1:14) S:$D(HBHCUPD) HBHCKEEP=1
21 Q
22ADMIT ; Set appropriate fields = null
23 F HBHCJ=19:1:37 S $P(^HBHC(631,HBHCDFN,0),U,HBHCJ)=""
24 S $P(^HBHC(631,HBHCDFN,1),U,14)=""
25 Q
26STATUS ; Set appropriate fields/variables for Discharge Status
27 K HBHCQ,HBHCQ1,HBHCKEEP
28 S HBHC12="^1^2^",HBHC359="^3^5^9^",HBHCNOD1=$G(^HBHC(631,HBHCDFN,1)),HBHCY0=^HBHC(631,HBHCDFN,0)
29 S:X="" Y=$S($D(HBHCUPD):0,1:65) S:HBHC12[(U_X_U) HBHCQ1=1,Y=44 S:HBHC359[(U_X_U) Y="@1" S:X=4 HBHCQ=1,Y=$S($D(HBHCUPD):0,1:69)
30 S HBHCTFLG=0 S:($P(HBHCY0,U,45)]"")!($P(HBHCY0,U,46)]"") HBHCTFLG=1
31 S HBHCDIED=0 S:$P($G(^HBHC(631,HBHCDFN,1)),U,15)]"" HBHCDIED=1
32 S HBHCDFLG=0 F HBHCL=47:1:55 Q:HBHCDFLG S:$P(HBHCY0,U,HBHCL)]"" HBHCDFLG=1
33 I HBHCNOD1]"" F HBHCM=1:1:10 Q:HBHCDFLG S:$P(HBHCNOD1,U,HBHCM)]"" HBHCDFLG=1
34 Q:(HBHCTFLG=0)&(HBHCDIED=0)&(HBHCDFLG=0)
35 Q:(HBHC12[(U_X_U))&(HBHCDIED=0)
36 Q:(X=4)&(HBHCTFLG=0)&(HBHCDFLG=0)
37 Q:(HBHC359[(U_X_U))&(HBHCTFLG=0)&(HBHCDIED=0)
38 S HBHCWRD1=$S(HBHCTFLG:"transfer",HBHCDIED:"deceased",1:"discharge")
39 S HBHCWRD2=$S(X="":"to 'Delete'",HBHC12[(U_X_U):"'Transfer' in",X=4:"'Died' in",1:"'Discharge' in")
40 S HBHCWRD3=$S(HBHCTFLG:"1 or 2 for Transfer",HBHCDIED:"4 for Died on HBHC",1:"3, 5 or 9 for Discharge")
41 D PROCDIS Q:%'=1
42 S:HBHCTFLG $P(^HBHC(631,HBHCDFN,0),U,45)="",$P(^HBHC(631,HBHCDFN,0),U,46)=""
43 D:(HBHCDFLG)&((X=4)!(X="")) DISCHRG
44 S:HBHCDIED $P(^HBHC(631,HBHCDFN,1),U,15)=""
45 Q
46PROCDIS ; Process 'Delete', '1 or 2', '4', & '3 or 5 or 9' responses
47 W *7,!!,"This record contains ",HBHCWRD1," data. Are you sure you want ",HBHCWRD2," the",!,"Discharge Status field ('Yes' will delete the ",HBHCWRD1," data)" S %=2 D YN^DICN
48 W ! W:%=0 !!,"Discharge Status field must contain ",HBHCWRD3," or the ",HBHCWRD1,!,"data MUST be deleted by responding 'Yes'.",!!
49 I %'=1 S Y=$S($D(HBHCUPD):0,1:43) S:$D(HBHCUPD) HBHCKEEP=1
50 Q
51DISCHRG ; Delete discharge data
52 F HBHCI=47:1:55 S $P(^HBHC(631,HBHCDFN,0),U,HBHCI)=""
53 F HBHCJ=1:1:10 S $P(^HBHC(631,HBHCDFN,1),U,HBHCJ)=""
54 S $P(^HBHC(631,HBHCDFN,1),U,16)=""
55 Q
56START ; Prompt for beginning/ending report dates
57 W ! K %DT S (HBHCBEG1,HBHCEND1,HBHCPAGE)=0,%DT("A")="Beginning Report Date: ",%DT="AEX" D ^%DT S HBHCBEG1=Y Q:HBHCBEG1=-1 D DD^%DT S HBHCBEG2=Y
58END ; Ending date prompt
59 S %DT("A")="Ending Report Date: " D ^%DT I (Y>0)&(Y<HBHCBEG1) W *7,!!,"Ending Report Date must be closer to today than the Beginning Report Date",! G END
60 S HBHCEND1=Y_.9999 Q:HBHCEND1=-1 D DD^%DT S HBHCEND2=Y
61TODAY ; Obtain current date
62 S $P(HBHCZ,"=",81)=""
63 K %DT S X="T" D ^%DT,DD^%DT S HBHCTDY=Y K %DT
64 Q
65HDRPAGE ; Print header with Page
66 S HBHCPAGE=HBHCPAGE+1
67 W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?71,"Page: ",HBHCPAGE,!!,"Run Date: ",HBHCTDY,!! I $D(HBHCHDR) X HBHCHDR W !
68 W HBHCZ
69 Q
70HDRRANGE ; Print header with Date Range
71 S HBHCPAGE=HBHCPAGE+1
72 W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?71,"Page: ",HBHCPAGE,! W:$D(HBHCNAM) ?HBHCCLM1,$S($D(HBHCONE):"Provider: ",1:"HBPC Team: "),HBHCNAM,! W !,"Run Date: ",HBHCTDY,?53,"Date Range: ",HBHCBEG2," to",!?65,HBHCEND2,!
73 I $D(HBHCHDR) X HBHCHDR W !
74 W HBHCZ
75 Q
76HDR132 ; Print 132 column header with Date Range
77 S HBHCPAGE=HBHCPAGE+1
78 W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?123,"Page: ",HBHCPAGE,! W:$D(HBHCNAM) ?HBHCCLM1,HBHCWHOC_": ",HBHCNAM,! W !,"Run Date: ",HBHCTDY,?105,"Date Range: ",HBHCBEG2," to",!?117,HBHCEND2,! I $D(HBHCHDR) X HBHCHDR W !
79 W HBHCZ
80 Q
81HDR132NR ; Print 132 column header with No Date Range
82 S HBHCPAGE=HBHCPAGE+1
83 W !?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<",?123,"Page: ",HBHCPAGE,! W !,"Run Date: ",HBHCTDY I $D(HBHCHDR) X HBHCHDR W !
84 W HBHCZ
85 Q
Note: See TracBrowser for help on using the repository browser.