source: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBML2.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1PSBML2 ;BIRMINGHAM/TEJ-BCMA UTILITY TO EDIT THE PSB MED LOG ;18 Apr 2005 10:13 AM
2 ;;3.0;BAR CODE MED ADMIN;**3,18,22,23,13**;Mar 2004
3 ;
4 ; Reference/IA
5 ; EN^PSJBCMA3/3320
6 ; ENE^PSJBCMA4/3416
7 ; ENR^PSJBCMA4/3416
8 ;
9 ;
10EDIT ;
11 K RESULTS S PSBEDIEN=PSBIEN_",",RESULTS(0)=0
12 I $G(PSBREC(7))']"" S RESULTS(0)=1,RESULTS(1)="-1^Data NOT filed - Comment is required" Q
13 D
14 .S PSBEDTFL=1,PSBMODS=0,PSBREC(1)=""
15 .D:PSBREC(4)]"" VAL^PSBML(53.79,PSBEDIEN,.06,PSBREC(4))
16 .I (PSBREC(0)="N") D
17 ..I ($$GET1^DIQ(53.79,PSBEDIEN,.11)["V") F PSBX=1:1:6 S PSBREC(PSBX)=""
18 .I ("NHR"[PSBREC(0)),$D(^PSB(53.79,+PSBEDIEN,.2)) D
19 ..; Audit PRN
20 ..D:$P(^PSB(53.79,+PSBEDIEN,.2),U,2)]"" AUDIT^PSBUTL(+PSBEDIEN,53.79,.22,$P(^PSB(53.79,+PSBEDIEN,.2),U,2),"K")
21 ..I ($P(^PSB(53.79,+PSBEDIEN,0),U,9)="G")!($P(^PSB(53.79,+PSBEDIEN,0),U,9)="I") D
22 ...I $D(^PSB(53.79,"APRN",$P(^PSB(53.79,+PSBEDIEN,0),U,1),$P(^PSB(53.79,+PSBEDIEN,0),U,6),+PSBEDIEN)) D
23 ....K ^PSB(53.79,"APRN",$P(^PSB(53.79,+PSBEDIEN,0),U,1),$P(^PSB(53.79,+PSBEDIEN,0),U,6),+PSBEDIEN) K ^PSB(53.79,+PSBEDIEN,.2)
24 .I ("NHR"'[PSBREC(0)) D:$G(PSBREC(5))]"" VAL^PSBML(53.79,PSBEDIEN,.21,$G(PSBREC(5))) D:$G(PSBREC(6))]"" VAL^PSBML(53.79,PSBEDIEN,.22,$G(PSBREC(6)))
25 .I +$G(RESULTS(0))<0 S RESULTS(1)="-1^Data NOT filed - "_$P(RESULTS(0),U,2),RESULTS(0)=1 Q
26 .D:$D(^PSB(53.79,+PSBEDIEN,.2)) VAL^PSBML(53.79,PSBEDIEN,.21,$G(PSBREC(5))),VAL^PSBML(53.79,PSBEDIEN,.22,$G(PSBREC(6)))
27 .D VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(7))
28 .D VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
29 .D VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
30 Q:+$G(RESULTS(1))<0
31 S PSBMODS=$$CHANGE^PSBML3(.PSBREC,PSBEDIEN)
32 D:PSBMODS UPDATED
33 D:('$G(PSBERR))&('$G(PSBMODS)) FILEIT^PSBML
34 ; Audit DD
35 I $D(PSBORDMD) S (PSBXY,PSBXZ)="" D
36 .F S PSBXY=$O(PSBORDMD(PSBXY)) Q:PSBXY="" S PSBFDAX=$S(PSBXY=.6:53.796,PSBXY=.7:53.797,1:53.795) F S PSBXZ=$O(PSBORDMD(PSBXY,PSBXZ)) Q:PSBXZ="" D
37 ..S PSBXACT="",PSBXACT=$G(PSBORDMD(PSBXY,PSBXZ,0))
38 ..D:PSBXACT["ADD" AUDIT^PSBUTL(+PSBEDIEN,PSBFDAX,.01,PSBXZ,"S") D:PSBXACT["DELETE" AUDIT^PSBUTL(+PSBEDIEN,PSBFDAX,.01,PSBXZ,"K")
39 ;
40 K PSBORDMD,PSBCHNG,PSBDDX,PSBEDTFL,PSBEDIEN,PSBFILED
41 Q
42 ;
43UPDATED ;
44 N PSBADD
45 S PSBIEN=PSBIEN_",",PSBXPTCH=0
46 S PSBRECNO=$S(PSBEDTFL:8,1:4)
47 I "^G^N^H^R^RM^S^C^I^M^"[(U_PSBREC(0)_U) D
48 .D:('PSBEDTFL) VAL^PSBML(53.79,PSBIEN,.06,PSBNOW)
49 .D:$D(PSBREC(4,0)) VAL^PSBML(53.79,PSBIEN,.06,PSBREC(4))
50 .D VAL^PSBML(53.79,PSBIEN,.07,"`"_DUZ)
51 .D:('PSBEDTFL)!($G(PSBREC(0,0))) VAL^PSBML(53.79,PSBIEN,.09,PSBREC(0))
52 .I $G(PSBREC(3))]"" D VAL^PSBML(53.79,PSBIEN,.26,PSBREC(3))
53 I $D(PSBREC(PSBRECNO)) D:($G(PSBREC(0))="G")&($P(PSBREC(PSBRECNO),U,5)["PATCH") Q:+$G(RESULTS(1))<0
54 .Q:$$GET1^DIQ(53.79,PSBIEN,.09,"I")=""
55 .S PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
56 .S PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
57 .S PSBXDT="" F S PSBXDT=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT)) Q:PSBXDT="" D Q:+$G(RESULTS(1))<0
58 ..S PSBYZ="" F S PSBYZ=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT,PSBYZ)) Q:'PSBYZ I ($$GET1^DIQ(53.79,PSBYZ,.09,"I")="G"),(PSBYZ'=+PSBIEN) S RESULTS(0)=1,RESULTS(1)="-1^Previous Patch has not been removed. Administration canceled." Q
59 D:$G(PSBREC(0))="N"
60 .I (PSBREC(0)="N"),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBREC(1)="Undo Given: "_$G(PSBREC(1))
61 .I ((PSBREC(0)="N")!(PSBREC(0)="G")),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM") S PSBREC(1)="Undo Remove: "_$G(PSBREC(1))
62 .; Undo PRN
63 .I $D(^PSB(53.79,+PSBIEN,.2)) D
64 ..D:$P(^PSB(53.79,+PSBIEN,.2),U,2)]"" AUDIT^PSBUTL(+PSBIEN,53.79,.22,$P(^PSB(53.79,+PSBIEN,.2),U,2),"K")
65 ..I ($P(^PSB(53.79,+PSBIEN,0),U,9)="G")!($P(^PSB(53.79,+PSBIEN,0),U,9)="I") K ^PSB(53.79,"APRN",$P(^PSB(53.79,+PSBIEN,0),U,1),$P(^PSB(53.79,+PSBIEN,0),U,6),+PSBIEN),^PSB(53.79,+PSBIEN,.2)
66 D:$G(PSBREC(1))]""
67 .S:PSBREC(0)="H" PSBREC(1)="Held: "_PSBREC(1)
68 .S:PSBREC(0)="R" PSBREC(1)="Refused: "_PSBREC(1)
69 .S:PSBREC(0)="RM" PSBREC(1)="Removed: "_PSBREC(1)
70 .I $D(PSBFDA(53.793,"+2,"_PSBIEN,.01)) S PSBREC(1)=PSBREC(1)_(PSBFDA(53.793,"+2,"_PSBIEN,.01))
71 .D VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(1)),VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ),VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
72 S PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
73 I ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM"),((PSBREC(0)="N")!(PSBREC(0)="G")) D
74 .I '(($D(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIEN,.07,"I")=DUZ)) S RESULTS(0)=1,RESULTS(1)="-1^Verify PSB MANAGER allocation" Q
75 .S PSBXPTCH=1,PSBYY="",PSBGIVEN=0 F S PSBYY=$O(^PSB(53.79,+PSBIEN,.9,PSBYY),-1) Q:'PSBYY Q:(+$G(RESULTS(0))<0) Q:PSBGIVEN S PSBXDAT=$G(^(PSBYY,0)) D
76 ..I PSBXDAT["ACTION STATUS 'GIVEN'" D
77 ...S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYY,0),U)
78 ...S PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
79 ...S PSBYX=(PSBYY-2) I (PSBYX)>0 I ^PSB(53.79,+PSBIEN,.9,PSBYX,0)["ACTION DATE/TIME '" S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYX,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":")
80 ...S PSBXDT="" F S PSBXDT=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT)) Q:PSBXDT="" D Q:+$G(RESULTS(1))<0
81 ....S PSBYZ="" F S PSBYZ=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT,PSBYZ)) Q:'PSBYZ I ($$GET1^DIQ(53.79,PSBYZ,.09,"I")="G"),(PSBYZ'=+PSBIEN) S RESULTS(0)=1,RESULTS(1)="-1^Cannot UNDO! Order has GIVEN patch" Q
82 ...I '(+$G(RESULTS(1))<0) D S PSBGIVEN=1
83 ....D VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE),VAL^PSBML(53.79,PSBIEN,.07,"`"_$P(PSBXDAT,U,2)),VAL^PSBML(53.79,PSBIEN,.09,"G")
84 ..D:('(+$G(RESULTS(1))<0))&('PSBGIVEN)&($G(PSBXPTCH))&(PSBYY'>1)
85 ...S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYY,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":")
86 ...D VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE),VAL^PSBML(53.79,PSBIEN,.07,"`"_$$GET1^DIQ(53.79,+PSBIEN,.07,"I")),VAL^PSBML(53.79,PSBIEN,.09,"G") S PSBGIVEN=1
87 Q:(+$G(RESULTS(1))<0)
88 I PSBEDTFL,$G(PSBGIVEN),PSBXPTCH S PSBREC(0)="G",PSBUNTSG=$P(PSBREC(8),U,4) D VAL^PSBML(53.795,(1_","_PSBIEN),.03,$S(PSBUNTSG'=0:PSBUNTSG,1:1)) K PSBXPTCH
89 I $G(PSBREC(2))]"" D VAL^PSBML(53.79,PSBIEN,.16,PSBREC(2))
90 S PSBOLDUZ=$P(^PSB(53.79,+PSBIEN,0),U,7),PSBOLSTS=$P(^PSB(53.79,+PSBIEN,0),U,9)
91 I $G(PSBREC(PSBRECNO))]"" D ; DD/SOL/ADD
92 .I PSBREC(0)="G"!(PSBREC(0)="I")!(PSBREC(0)="H")!(PSBREC(0)="R")!(PSBREC(0)="M") D ; Only if gvn or infus
93 ..Q:(PSBEDTFL)&('$G(PSBCHNG))
94 ..F PSBCNT=PSBRECNO:1 Q:'$D(PSBREC(PSBCNT)) D
95 ...S Y=$P(PSBREC(PSBCNT),U)
96 ...S PSBDD=$S(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
97 ...Q:'PSBDD
98 ...I $G(PSBCHNG) D
99 ....I $D(PSBFIND(PSBCNT)) S PSBIENS=$QS($Q(PSBFIND(PSBCNT)),2)_","_PSBIEN
100 ....I '$D(PSBFIND(PSBCNT)) S PSBIENS="+1,"_PSBIEN
101 ....D VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
102 ....D VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
103 ....D VAL^PSBML(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4))
104 ....D:Y="DD" VAL^PSBML(PSBDD,PSBIENS,.04,$P(PSBREC(PSBCNT),U,5))
105 .I ('PSBEDTFL)!((PSBREC(0)'="G")&($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G")) D
106 ..S (PSBDCNT,PSBACNT,PSBSCNT)=0,PSBADD=3 F PSBCNT=PSBRECNO:1 Q:'$D(PSBREC(PSBCNT)) D
107 ...S Y=$P(PSBREC(PSBCNT),U)
108 ...S PSBDD=$S(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
109 ...Q:'PSBDD
110 ...S @("PSB"_$E(Y)_"CNT")=@("PSB"_$E(Y)_"CNT")+1
111 ...S PSBIENS=(@("PSB"_$E(Y)_"CNT"))_","_PSBIEN
112 ...I '$$GET1^DIQ(PSBDD,PSBIENS,.01,"I") S PSBIENS="+"_PSBADD_","_PSBIEN,PSBADD=PSBADD+1
113 ...D VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
114 ...D VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
115 ...D:Y="DD" VAL^PSBML(PSBDD,PSBIENS,.03,$S(PSBREC(0)="G"!(PSBREC(0)="RM"):$P(PSBREC(PSBCNT),U,4),1:0)),VAL^PSBML(PSBDD,PSBIENS,.04,$P(PSBREC(PSBCNT),U,5))
116 I ($G(PSBREC(PSBRECNO))']""),(PSBREC(0)="N"),($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G") D
117 .S PSBX=0 F S PSBX=$O(^PSB(53.79,+PSBIEN,.5,PSBX)) Q:'+PSBX D VAL^PSBML(53.795,(PSBX_","_PSBIEN),.03,0)
118 D FILEIT^PSBML
119 I $P($G(RESULTS(1)),U,1)=1 D
120 .S PSBUID=$P(^PSB(53.79,+PSBIEN,0),U,10) I PSBUID]"",PSBUID'["WS" D
121 ..S PSBTS=PSBREC(0)
122 ..S PSBON=$P(^PSB(53.79,+PSBIEN,.1),U,1)
123 ..S PSBDFN=$P(^PSB(53.79,+PSBIEN,0),U,1)
124 ..I PSBREC(0)="N" S PSBTS="" D
125 ...M PSBAR=^PSB(53.79,+PSBIEN,.9)
126 ...S (PSBDN,X)="" F S X=$O(PSBAR(X),-1) Q:X=0!(PSBDN=1) D
127 ....I PSBAR(X,0)["ACTION STATUS",PSBAR(X,0)["deleted",PSBAR(X,0)'["GIVEN" D
128 .....S PSBTS=$P($P(PSBAR(X,0),"'",2),"'",1)
129 .....S PSBTS=$S(PSBTS="HELD":"H",PSBTS="REFUSED":"R",PSBTS="REMOVED":"RM",PSBTS="MISSING":"M",1:""),PSBDN=1
130 ...D VAL^PSBML(53.79,PSBIEN,.26,"") D CLEAN^DILF,UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
131 ..D EN^PSJBCMA3(PSBDFN,+PSBON,PSBUID,PSBTS,PSBNOW)
132 I ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N") S PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I") D ENR^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
133 I ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I") D ENE^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
134 I (PSBREC(0)="N")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N") D NGRESET^PSBML3(.PSBREC,PSBIEN)
135 Q
136 ;
Note: See TracBrowser for help on using the repository browser.