source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBCSUTX.m@ 1705

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1PSBCSUTX ;BIRMINGHAM/TEJ- BCMA-HSC COVER SHEET UTILITIES 2 ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**16,13,38,32**;Mar 2004;Build 32
3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
4 ; Reference/IA
5 ; $$GET1^DIQ/2056
6 ; $$SCH^XLFDT/10103
7 ; $$FMADD^XLFDT/10103
8ADD ; otput: ORD-ORC-DD-ADD-SOL-ID-ADM-CMT-END segmnts
9 K PSBDONE S PSBRECHD="ORD",PSBDONE=0,PSBCNT1=^TMP("PSB",$J,PSBTAB,0),PSBCNT2=1,$P(^TMP("PSB",$J,"CVRSHT2",0),U)=0
10 F PSBI1=1:1:PSBCNT1 D Q:PSBDONE
11 .I PSBCNT1'>1 S PSBDONE=1 Q
12 .I PSBI1=1 S ^TMP("PSB",$J,"CVRSHT2",PSBCNT2)=^TMP("PSB",$J,"CVRSHT",1) Q
13 .I ^TMP("PSB",$J,PSBTAB,PSBI1)="END" S PSBRECHD="ORD",PSBCNT2=PSBCNT2+1,^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="END" Q
14 .I PSBRECHD="ORD" D ORD Q
15 .I PSBRECHD="ORC" D ORC^PSBCSUTY Q
16 .I PSBRECHD="ORF" D ORF^PSBCSUTY
17 .I PSBRECHD="MED" D MED^PSBCSUTY Q
18 S $P(^TMP("PSB",$J,"CVRSHT2",0),U)=PSBCNT2
19 M ^TMP("PSB",$J,PSBTAB)=^TMP("PSB",$J,"CVRSHT2") K PSBNXTDU D ADM
20 K ^TMP("PSB",$J,PSBTAB) M ^TMP("PSB",$J,PSBTAB)=^TMP("PSB",$J,"CVRSHT2") K ^TMP("PSB",$J,"CVRSHT2") D FINALPAS^PSBCSUTY
21 K ^TMP("PSB",$J,PSBTAB) M ^TMP("PSB",$J,PSBTAB)=^TMP("PSB",$J,"CVRSHT2") K ^TMP("PSB",$J,"CVRSHT2")
22 Q
23ORD ;
24 S PSBCNT2=PSBCNT2+1,(PSBORREC,PSBXREC)=^TMP("PSB",$J,PSBTAB,PSBI1)
25 S ($P(PSBXREC,U,12),$P(PSBXREC,U,23),$P(PSBXREC,U,24),PSBSCHTM,PSBONMBR,PSBIENX,PSBBAGID,PSBACT,PSBACTBY,PSBACTDT,PSBACTPT,PSBPRNRE,PSBXX,PSBXXX)=""
26 S ^TMP("PSB",$J,"CVRSHT2",PSBCNT2)="ORD",$P(^TMP("PSB",$J,"CVRSHT2",PSBCNT2),U,2)=PSBXREC
27 S PSBSCHTM=$P(PSBORREC,U,14),PSBONMBR=$P(PSBORREC,U,2),PSBIENX=$P(PSBORREC,U,12),PSBLRGIV=0
28 D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBONMBR) S:(PSBONMBR["V")&'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$G(PSBIVPSH)) PSBLRGIV=1
29 I '$D(PSBLST4X(PSBONMBR)) S PSBXX="" F PSBI=1:1 S PSBXX=$O(PSBADMX(PSBONMBR,PSBXX),-1) Q:PSBXX="" S PSBXXX="" D Q:$G(PSBLST4X(PSBONMBR))=4
30 .F S PSBXXX=$O(PSBADMX(PSBONMBR,PSBXX,PSBXXX)) Q:PSBXXX="" D Q:$G(PSBLST4X(PSBONMBR))=4
31 ..I $$GET1^DIQ(53.79,PSBXXX_",","ACTION STATUS","I")'="N" S PSBLST4X(PSBONMBR,PSBXXX)="",PSBLST4X(PSBONMBR)=$G(PSBLST4X(PSBONMBR))+1
32 ..I ($$GET1^DIQ(53.79,PSBXXX_",","ACTION STATUS","I")="N")&($O(PSBADMX(PSBONMBR,PSBXX))="") S PSBLST4X(PSBONMBR,PSBXXX)="",PSBLST4X(PSBONMBR)=$G(PSBLST4X(PSBONMBR))+1
33 I PSBIENX]"",$D(PSBLST4X(PSBONMBR,PSBIENX)) D
34 .S PSBBAGID=$$GET1^DIQ(53.79,PSBIENX_",","IV UNIQUE ID")
35 .S PSBACTDT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION DATE/TIME","I")
36 .S PSBACT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION STATUS","I")
37 .S PSBPRNRE=$$GET1^DIQ(53.79,PSBIENX_",","PRN REASON")
38 .S PSBACTBY=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY:INITIAL") S:PSBACTBY']"" PSBACTBY="***"
39 .S PSBACTPT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY","I")
40 .I '$D(PSBDONE(PSBIENX)) D
41 ..I PSBLRGIV,(PSBFON]"") Q
42 ..S PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^"_PSBBAGID_"^"_PSBIENX_"^"_PSBACT_"^"_PSBACTDT_"^"_PSBACTBY_"^"_PSBACTPT_"^"_PSBPRNRE
43 ..I PSBLRGIV D
44 ...I PSBOSP<PSBNOW S PSBADMS(PSBONMBR,"EXP")=""
45 ...S PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX,1)=1
46 ..S PSBDONE(PSBIENX)="" K PSBADMX(PSBONMBR,PSBSCHTM,PSBIENX) D
47 ...S PSBXX="" F S PSBXX=$O(PSBADMX(PSBONMBR,PSBXX)) Q:PSBXX="" I $D(PSBADMX(PSBONMBR,PSBXX,PSBIENX)) K PSBADMX(PSBONMBR,PSBXX,PSBIENX)
48 I PSBIENX']"" D
49 .S PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^^^^^^^"
50 .I PSBLRGIV S PSBADMS(PSBONMBR,PSBSCHTM,1)=1
51 I "^O^OC^P^"[(U_PSBSCHT_U)&('$D(PSBADMS(PSBONMBR))) S PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^^^^^^^"
52 S PSBRECHD="ORC" K PSBSCHTM S PSBXREC=""
53 Q
54ADM ; Admn data
55 K PSBDONE S (PSBONMBR,PSBSCHTM)="" F PSBI1=2:1:$P(^TMP("PSB",$J,PSBTAB,0),U) D
56 .I $P(^TMP("PSB",$J,PSBTAB,PSBI1),U)="ORD" S PSBONMBR=$P(^TMP("PSB",$J,PSBTAB,PSBI1),U,3),$P(^TMP("PSB",$J,"CVRSHT2",PSBI1),U,15)=""
57 .S (PSBXX,PSBXXX)="" F S PSBXX=$O(PSBADMX(PSBONMBR,PSBXX)) Q:PSBXX="" F S PSBXXX=$O(PSBADMX(PSBONMBR,PSBXX,PSBXXX)) Q:PSBXXX="" D
58 ..S PSBSCHTM=PSBXX,PSBIENX=PSBXXX
59 ..I $D(PSBNOX(PSBONMBR)) I $P(^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,""))),U)="NOX" K ^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,"")))
60 ..Q:'$D(PSBLST4X(PSBONMBR,PSBIENX))
61 ..S PSBACT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION STATUS","I")
62 ..I PSBACT']"" S PSBACT="U"
63 ..S PSBACTDT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION DATE/TIME","I")
64 ..S PSBBAGID=$$GET1^DIQ(53.79,PSBIENX_",","IV UNIQUE ID")
65 ..S PSBPRNRE=$$GET1^DIQ(53.79,PSBIENX_",","PRN REASON")
66 ..S PSBACTBY=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY:INITIAL") S:PSBACTBY']"" PSBACTBY="***"
67 ..S PSBACTPT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION BY","I")
68 ..S PSBADMS(PSBONMBR,PSBSCHTM_PSBIENX)=PSBSCHTM_"^"_PSBBAGID_"^"_PSBIENX_"^"_PSBACT_"^"_PSBACTDT_"^"_PSBACTBY_"^"_PSBACTPT_"^"_PSBPRNRE
69 ..I PSBIENX]"" K PSBADMX(PSBONMBR,PSBSCHTM,PSBIENX)
70 .I '$D(PSBADMS(PSBONMBR)) K ^TMP("PSB",$J,"CVRSHT2",PSBI1) Q
71 .I $P(^TMP("PSB",$J,PSBTAB,PSBI1),U)="END" K PSBADMS(PSBONMBR) Q
72 .I $P(^TMP("PSB",$J,PSBTAB,PSBI1+1),U)="END" D Q
73 ..S PSBCNT2=1,PSBSCHTM=""
74 ..F S PSBSCHTM=$O(PSBADMS(PSBONMBR,PSBSCHTM)) Q:+$G(PSBSCHTM)=0 D
75 ...S PSBIENX=$P(PSBADMS(PSBONMBR,PSBSCHTM),U,3)
76 ...I PSBIENX]"",'$D(PSBDONE(PSBIENX)) D
77 ....I $D(PSBNOX(PSBONMBR)) I $P(^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,""))),U)="NOX" K ^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,"")))
78 ....S PSBACT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION STATUS","I")
79 ....I PSBACT']"" S PSBACT="U"
80 ....S PSBACTDT=$$GET1^DIQ(53.79,PSBIENX_",","ACTION DATE/TIME","I")
81 ....Q:PSBACT="N"
82 ....Q:$D(PSBADMS(PSBONMBR,"EXP"))&("SI"'[PSBACT)
83 ....S $P(PSBADMS(PSBONMBR,PSBSCHTM),U,4)=PSBACT
84 ....S ^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2)="ADM^"_PSBADMS(PSBONMBR,PSBSCHTM)_"^"_$$NEXTADM(PSBDFNX,PSBONMBR),PSBCNT2=PSBCNT2+1
85 ....S PSBDONE(PSBIENX)=""
86 ....D CMT^PSBCSUTY
87 ...I (PSBIENX']"")&($G(PSBADMS(PSBONMBR,PSBSCHTM,1))'=1) D
88 ....S ^TMP("PSB",$J,"CVRSHT2",PSBI1,PSBCNT2)="ADM^"_PSBADMS(PSBONMBR,PSBSCHTM)_"^"_$$NEXTADM(PSBDFNX,PSBONMBR),PSBCNT2=PSBCNT2+1
89 ....I $D(PSBNOX(PSBONMBR)) I $P(^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,""))),U)="NOX" K ^TMP("PSB",$J,"CVRSHT2",$O(PSBNOX(PSBONMBR,"")))
90 K PSBSCHTM
91 Q
92NEXTADM(XX,YY) ;
93 S NEXTADM=""
94 I $D(PSBNXTDU(YY)) S NEXTADM=PSBNXTDU(YY) Q NEXTADM
95 D:YY'["P"
96 .S PSBPATX=XX,PSBORXX=YY D CLEAN^PSBVT,PSJ1^PSBVT(XX,YY)
97 .Q:(PSBORXX["V")&'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,+$G(PSBIVPSH))
98 .S PSBGSCH=PSBADST,XX=PSBPATX,YY=PSBORXX,(NEXTADM,X,Y)="",X=$O(^PSB(53.79,"AORD",XX,YY,X),-1)
99 .I X]"" S Y=$O(^PSB(53.79,"AORD",XX,YY,X,Y),-1) I ($F("NM",$P(^PSB(53.79,Y,0),U,9))>1)!($P(^PSB(53.79,Y,0),U,9)="") S NEXTADM=X
100 .D:X']""
101 ..S Y="",X=$O(^PSB(53.79,"AORDX",XX,YY,X),-1)
102 ..I X]"" S Y=$O(^PSB(53.79,"AORDX",XX,YY,X,Y),-1) I $F("NM",$P(^PSB(53.79,Y,0),U,9))>1!($P(^PSB(53.79,Y,0),U,9)="") S NEXTADM=$P(^PSB(53.79,Y,0),U,6)
103 .D:NEXTADM=""
104 ..S PSBGOTY=Y,PSBFREQ=$$GETFREQ^PSBVDLU1(XX,YY)
105 ..S PSBFREQ=$S(PSBFREQ="O":1440,PSBFREQ="D":"",1:PSBFREQ)
106 ..S (PSBXSCH,LSTTIME,LSTIEN)=""
107 ..S:PSBGOTY]"" LSTTIME=$O(^PSB(53.79,"AORD",PSBPATX,PSBORXX,LSTTIME),-1) I LSTTIME]"" S LSTIEN=$O(^PSB(53.79,"AORD",PSBPATX,PSBORXX,LSTTIME,""),-1)
108 ..I LSTIEN]"" S:$P(^PSB(53.79,LSTIEN,0),U,9)']"" LSTTIME=""
109 ..S:LSTTIME="" LSTTIME=$$FMADD^XLFDT(PSBOST,,,,-0.1)
110 ..I +PSBFREQ>0 S PSBXSCH=(+PSBFREQ/60)_"H"
111 ..S X=LSTTIME
112 ..F PSBIX1=1:1:($L(PSBGSCH,"-")+1) D Q:NEXTADM>LSTTIME
113 ...I ($P(PSBGSCH,"-",PSBIX1))']"" D Q
114 ....I PSBIX1=1 D Q
115 .....I X<PSBOST S NEXTADM=PSBOST Q
116 .....S X=PSBOST F S X=$$SCH^XLFDT(PSBXSCH,X) S Y="" S Y=$O(^PSB(53.79,"AORD",PSBPATX,PSBORXX,Y),-1) I X>Y S NEXTADM=X Q
117 ....I PSBGSCH]"" D Q
118 .....I (+PSBFREQ'>1440) F I=0:1 S PSBDTXX=$$FMADD^XLFDT(PSBOST,I) S $P(PSBDTXX,".",2)=($P(PSBGSCH,"-")) I PSBDTXX>LSTTIME S NEXTADM=PSBDTXX Q
119 .....I (+PSBFREQ'<1440),(1440#PSBFREQ=1440) F I=0:1 S PSBDTXX=$$FMADD^XLFDT(PSBOST,(I*(PSBFREQ\1440))) S $P(PSBDTXX,".",2)=($P(PSBGSCH,"-")) I PSBDTXX>LSTTIME S NEXTADM=PSBDTXX Q
120 ....S $P(X,".",2)=$P(PSBGSCH,"-"),NEXTADM=$$SCH^XLFDT(PSBXSCH,X) Q
121 ...S $P(X,".",2)=$P(PSBGSCH,"-",PSBIX1) S:X<PSBOSP NEXTADM=X
122 .S:NEXTADM'<PSBOSP NEXTADM=""
123 .I $$PSBDCHK1^PSBVT1(PSBSCH) D
124 ..S YY=PSBORXX,XX=PSBPATX
125 ..I $G(LSTTIME)]"" S NEXTADM=$S(LSTTIME'<PSBOST:LSTTIME,NEXTADM>LSTTIME:NEXTADM,1:PSBOST)
126 ..I PSBFREQ="" S PSBDTX=$P(NEXTADM,".") F PSBIX3=0:1 S X=$$FMADD^XLFDT(PSBDTX,PSBIX3) Q:X>PSBOSP D Q:$G(PSBYS)
127 ...S PSBNXTDT=X D DW^%DTC S PSBYS=0 F PSBIX2=1:1 S PSBDY=$P($P(PSBSCH,"@"),"-",PSBIX2) Q:PSBDY="" I $F(X,PSBDY)>1 S PSBYS=1
128 ...I PSBYS S PSBSCTM=$$GETADMIN^PSBVDLU1(XX,YY,PSBNXTDT,"","") K ^TMP("PSB",$J,"GETADMIN") D
129 ....F PSBIX4=1:1 S PSBTX=$P(PSBSCTM,"-",PSBIX4) Q:PSBTX="" D Q:PSBYS
130 .....I NEXTADM>(PSBNXTDT_"."_PSBTX) S PSBYS=0 Q
131 .....S NEXTADM=PSBNXTDT,$P(NEXTADM,".",2)=PSBTX
132 .....I NEXTADM]"" I (NEXTADM<PSBOST)!$D(^PSB(53.79,"AORD",PSBPATX,PSBORXX,+NEXTADM))!(NEXTADM>PSBOSP) S PSBYS=0,NEXTADM="" Q
133 .....S PSBYS=1
134 .S PSBNXTDU(PSBORXX)=NEXTADM
135 .D CLEAN^PSBVT
136 Q NEXTADM
Note: See TracBrowser for help on using the repository browser.