source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBML3.m@ 1076

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

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1PSBML3 ;BIRMINGHAM/TEJ-BCMA UTILITY TO EDIT THE PSB MED LOG ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**3,13,39,41**;Mar 2004;Build 1
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ; Reference/IA
6 ; $$GET1^DIQ/2056
7 ;
8APATCH ; Maintain "APATCH" index...
9 I $G(PSBTRAN)["MEDPASS" D:$P(PSBREC(9),U)="UDTAB" Q
10 .S PSBX1=9,PSBQUT=0 F S PSBX1=$O(PSBREC(PSBX1)) Q:PSBQUT Q:'(+PSBX1) D:$P(PSBREC(PSBX1),U)="DD"&($P(PSBREC(PSBX1),U,5)="PATCH") Q:PSBQUT
11 ..I $G(PSBOLSTS)="",PSBREC(3)="G" S PSB1="I $D(PSBIEN(1)) S ^PSB(53.79,""APATCH"","_$G(PSBREC(0))_","_$G(PSBNOW)_",+PSBIEN(1))="""""
12 ..S PSBQUT=1
13 S PSBX1=0 F S PSBX1=$O(^PSB(53.79,+PSBIEN,.5,PSBX1)) Q:'(+PSBX1) Q
14 I $G(PSBTRAN)["UPDATE",(+PSBX1)'=0 D
15 .S PSBX3=0 F S PSBX3=$O(^PSB(53.79,+PSBIEN,.5,PSBX3)) Q:+PSBX3=0 I $P(^PSB(53.79,+PSBIEN,.5,PSBX3,0),U,4)="PATCH" D
16 ..I PSBOLSTS="G",PSBREC(0)="N" S PSB1="K ^PSB(53.79,""APATCH"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$P(^PSB(53.79,+PSBIEN,0),U,6)_","_+PSBIEN_")"
17 ..I PSBFDA(53.79,+PSBIEN_",",.09)="G" S PSB1="S ^PSB(53.79,""APATCH"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$G(PSBFDA(53.79,+PSBIEN_",",.06))_","_+PSBIEN_")"_"="""""
18 I $G(PSBTRAN)["EDIT",(+PSBX1)'=0 D
19 .S PSBX3=0 F S PSBX3=$O(^PSB(53.79,+PSBIEN,.5,PSBX3)) Q:+PSBX3=0 I $P(^PSB(53.79,+PSBIEN,.5,PSBX3,0),U,4)="PATCH",((PSBREC(0)="G")!(PSBREC(0)="RM")) D
20 ..S PSB1="S ^PSB(53.79,""APATCH"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$G(PSBFDA(53.79,+PSBIEN_",",.06))_","_+PSBIEN_")"_"="""""
21 ..I $D(PSBREC(4,0)) S PSB2="K ^PSB(53.79,""APATCH"","_$P(^PSB(53.79,+PSBIEN,0),U)_","_$G(PSBREC(4,0))_","_+PSBIEN_")"
22 Q
23 ;
24CHANGE(PSBREC,PSBEDIEN) ;Determine an order edit
25 S PSBCHNG=0
26 K PSBORDMD,PSBDDX
27 I PSBREC(0)'=$$GET1^DIQ(53.79,PSBEDIEN,.09,"I") S PSBREC(0,0)=1,PSBCHNG=1
28 I PSBREC(2)'=$$GET1^DIQ(53.79,PSBEDIEN,.16,"I") S PSBREC(2,0)=1,PSBCHNG=1
29 I PSBREC(4)'=$$GET1^DIQ(53.79,PSBEDIEN,.06,"I") S PSBREC(4,0)=$$GET1^DIQ(53.79,PSBEDIEN,.06,"I"),PSBCHNG=1
30 I PSBREC(5)'=$$GET1^DIQ(53.79,PSBEDIEN,.21) S PSBREC(5,0)=1,PSBCHNG=1
31 I PSBREC(6)'=$$GET1^DIQ(53.79,PSBEDIEN,.22) S PSBREC(6,0)=1,PSBCHNG=1
32 K PSBFIND,PSBFOUN,PSBREC2
33 F PSBRECNX=8:1 Q:'$D(PSBREC(PSBRECNX)) S PSBDPTR=$P(PSBREC(PSBRECNX),U,2),PSBORDMD(PSBRECNX,PSBDPTR,0)="ADDED"
34 F PSBDDX=.5,.6,.7 D:$D(^PSB(53.79,+PSBEDIEN,PSBDDX,"B"))
35 .S PSBDPTR="" F S PSBDPTR=$O(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR)) Q:+PSBDPTR'>0 D
36 ..S PSBXX=0 F S PSBXX=$O(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR,PSBXX)) Q:+PSBXX'>0 D Q:'$$FINDDD^PSBML3(PSBDDX,PSBDPTR)
37 ...I '$D(PSBFOUN(PSBDDX,PSBXX)) F PSBRECNX=8:1 Q:'$D(PSBREC(PSBRECNX)) D:$D(PSBORDMD(PSBRECNX)) Q:$D(PSBFOUN(PSBDDX,PSBXX))
38 ....S PSBDFDA=$P(PSBREC(PSBRECNX),U) Q:$S(PSBDFDA="DD":.5,PSBDFDA="ADD":.6,PSBDFDA="SOL":.7)'=PSBDDX
39 ....S PSBDATAX=PSBDFDA_"^"_$G(^PSB(53.79,+PSBEDIEN,PSBDDX,PSBXX,0))_$S(PSBDDX'=.5:"^",1:"")
40 ....S:$P(PSBDATAX,U,3)?1"."1.N $P(PSBDATAX,U,3)=0_+$P(PSBDATAX,U,3)
41 ....S:$P(PSBDATAX,U,4)?1"."1.N $P(PSBDATAX,U,4)=0_+$P(PSBDATAX,U,4)
42 ....I PSBDATAX=PSBREC(PSBRECNX) K PSBORDMD(PSBRECNX),PSBREC2(PSBRECNX) S (PSBFIND(PSBRECNX,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1 Q
43 ....S PSBUNTOR=$P(PSBDATAX,U,3),PSBUNTGN=$P(PSBDATAX,U,4),PSBUNTAD=$P(PSBDATAX,U,5)
44 ....I PSBREC(PSBRECNX)[(PSBDFDA_"^"_PSBDPTR_"^"_PSBUNTOR_"^") S PSBREC2(PSBRECNX)=PSBREC(PSBRECNX)
45 D:$D(PSBREC2)
46 .F PSBDDX=.5,.6,.7 D:$D(^PSB(53.79,+PSBEDIEN,PSBDDX,"B"))
47 ..S PSBDPTR="" F S PSBDPTR=$O(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR)) Q:+PSBDPTR'>0 D
48 ...S PSBXX=0 F S PSBXX=$O(^PSB(53.79,+PSBEDIEN,PSBDDX,"B",PSBDPTR,PSBXX)) Q:+PSBXX'>0 D
49 ....S PSBREC2X=0 F S PSBREC2X=$O(PSBREC2(PSBREC2X)) Q:PSBREC2X="" D Q:$G(PSBFOUN(PSBDDX,PSBXX))
50 .....S PSBDFDA=$P(PSBREC(PSBREC2X),U) Q:$S(PSBDFDA="DD":.5,PSBDFDA="ADD":.6,PSBDFDA="SOL":.7)'=PSBDDX
51 .....S PSBDATAX=PSBDFDA_"^"_$G(^PSB(53.79,+PSBEDIEN,PSBDDX,PSBXX,0))
52 .....S:$P(PSBDATAX,U,3)?1"."1.N $P(PSBDATAX,U,3)=0_+$P(PSBDATAX,U,3)
53 .....S:$P(PSBDATAX,U,4)?1"."1.N $P(PSBDATAX,U,4)=0_+$P(PSBDATAX,U,4)
54 .....I PSBDATAX=PSBREC(PSBREC2X) K PSBREC2(PSBREC2X),PSBORDMD(PSBREC2X) S (PSBFIND(PSBREC2X,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1 Q
55 .....S PSBUNTOR=$P(PSBDATAX,U,3),PSBUNTGN=$P(PSBDATAX,U,4),PSBUNTAD=$P(PSBDATAX,U,5)
56 .....I PSBREC2(PSBREC2X)[(PSBDFDA_"^"_PSBDPTR_"^"_PSBUNTOR_"^") I '$D(PSBFOUN(PSBDDX,PSBXX)) S (PSBCHNG,PSBFIND(PSBREC2X,PSBXX),PSBFOUN(PSBDDX,PSBXX))=1 D Q
57 ......N PSBY,Y F Y=4,5 S PSBY=$P(PSBREC2(PSBREC2X),U,Y) S:PSBY'=$S(Y=4:PSBUNTGN,Y=5:PSBUNTAD) PSBORDMD(PSBREC2X,PSBDPTR,0)=""
58 ; Modify FDA per Deleted DDs
59 ;
60 F PSBX=.5,.6,.7 S PSBXX="" F Q:'$D(PSBORDMD(PSBX)) S PSBXX=$O(PSBORDMD(PSBX,PSBXX)) Q:$G(PSBXX)="" D:PSBORDMD(PSBX,PSBXX,0)["DELETE"
61 .S PSBDDX=$S(PSBX=.5:53.795,PSBX=.6:53.796,1:53.797)
62 .S PSBIENX="^PSB(53.79,"_($G(PSBEDIEN))_($G(PSBX))_",""B"","_PSBXX_")"
63 .S PSBIENX=$Q(@PSBIENX),PSBIENX=$QS(PSBIENX,6)_","_(+PSBEDIEN)
64 .D:'$D(PSBFOUN(PSBDDX,+PSBIENX)) VAL^PSBML(PSBDDX,PSBIENX,.01,""),VAL^PSBML(PSBDDX,PSBIENX,.02,""),VAL^PSBML(PSBDDX,PSBIENX,.03,""),VAL^PSBML(PSBDDX,PSBIENX,.04,"")
65 ;
66 S:$D(PSBORDMD) PSBCHNG=1 K PSBREC2
67 Q PSBCHNG
68 ;
69NGRESET(PSBREC,PSBREIEN) ;
70 ;
71 ; Acknowledged "UNDO" - reinstate previous status and state...
72 ;
73 I (PSBREC(0)="N")&($$GET1^DIQ(53.79,PSBREIEN,.09,"I")="N") D I '$D(PSBQUITX) S PSBREINT=$$GET1^DIQ(53.79,PSBREIEN,.05,"I")
74 .S PSBRESET="NOT GIVEN",PSBX="B" K PSBQUITX,PSBREXDT,PSBREINT F S PSBX=$O(^PSB(53.79,+PSBREIEN,.9,PSBX),-1) Q:PSBX'>0 D Q:($G(PSBQUITX))!(PSBX'>0)
75 ..I (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION STATUS Set to") Q
76 ..I $P(^PSB(53.79,+PSBREIEN,.9,PSBX,0),U,4)=PSBRESET D Q:$G(PSBQUITX) Q:PSBX'>0
77 ...S PSBREXDT=$P(^PSB(53.79,+PSBREIEN,.9,PSBX,0),U)
78 ...F S PSBX=$O(^PSB(53.79,+PSBREIEN,.9,PSBX),-1) Q:PSBX'>0 D Q:$G(PSBQUITX)
79 ....I (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION STATUS")!(^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["deleted") Q
80 ....I $P(^PSB(53.79,+PSBREIEN,.9,PSBX,0),"'",2)'="GIVEN" Q
81 ....F S PSBX=$O(^PSB(53.79,+PSBREIEN,.9,PSBX),-1) Q:(PSBX'>0)!($G(PSBQUITX)) D Q:$G(PSBQUIT)
82 .....I (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION STATUS ")!(^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["deleted") Q
83 .....S PSBRESET=$P(^PSB(53.79,+PSBREIEN,.9,PSBX,0),"'",2) I (PSBRESET="GIVEN")!(PSBRESET="REMOVED") Q
84 .....S PSBREXDT=$$GET1^DIQ(53.79,PSBREIEN,.04,"I"),PSBX=PSBX-2 I '$D(^PSB(53.79,+PSBREIEN,.9,PSBX,0)) S PSBQUIT=1 Q
85 .....I (^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["ACTION DATE/TIME")!(^PSB(53.79,+PSBREIEN,.9,PSBX,0)'["deleted") S PSBQUIT=1 Q
86 .....S PSBREXDT=$P(^PSB(53.79,+PSBREIEN,.9,PSBX,0),"'",2),X=$P(PSBREXDT,"@"),%DT="" D ^%DT S PSBREXDT=Y_"."_$TR($P(PSBREXDT,"@",2),":"),PSBQUIT=1
87 I $D(PSBREINT),$D(PSBREXDT),($D(PSBRESET)&($G(PSBRESET)'="GIVEN")) D
88 .D VAL^PSBML(53.79,PSBREIEN,.06,PSBREXDT)
89 .D VAL^PSBML(53.79,PSBREIEN,.09,PSBRESET)
90 .D:$D(PSBREINT) VAL^PSBML(53.79,PSBREIEN,.07,"`"_PSBREINT)
91 .D:'$G(PSBERR) FILEIT^PSBML
92 K PSBXXX,PSBRESET,PSBREXDT,PSBREINT,PSBQUITX
93 Q
94 ;
95FINDDD(PSBDDXX,PSBDDPTR) ;
96 ;
97 ; Determine if edit - 'change' is deleted DDrug
98 ;
99 S FINDDD=0
100 I $D(PSBREC(8)) D
101 .F PSBINDX=8:1 Q:'$D(PSBREC(PSBINDX)) S PSBCOMPX=$G(PSBREC(PSBINDX)) D Q:FINDDD
102 ..I ($S(PSBDDXX=.5:"DD",PSBDDXX=.6:"ADD",PSBDDXX=.7:"SOL",1:"")=$P(PSBCOMPX,U)),(PSBDDPTR=$P(PSBCOMPX,U,2)) S FINDDD=1
103 I 'FINDDD S PSBORDMD(PSBDDXX,PSBDDPTR,0)="DELETED"
104 Q FINDDD
105 ;
Note: See TracBrowser for help on using the repository browser.