source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBML1.m@ 757

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

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1PSBML1 ;BIRMINGHAM/VRN-BCMA API TO IPM FOR EXPIRING ONE-TIME ORDERS ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**3**;Mar 2004
3 ;
4 ; Reference/IA
5 ; EN^PSJBCMA3/3320
6 ; ENE^PSJBCMA4/3416
7 ; ENR^PSJBCMA4/3416
8 ; ^XUSEC/10076
9 ;
10EXPIRE ;
11 S PSBFLAG=0,(X,Y)=""
12 F S X=$O(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X),-1) Q:X="" D
13 .F S Y=$O(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X,Y),-1) Q:'Y D
14 ..I $D(^PSB(53.79,Y,.3)),$G(^PSB(53.79,Y,.3,1,0))["Manual" S PSBFLAG=1
15 ..D:('PSBFLAG)&($P(^PSB(53.79,Y,0),U,9)="G") ENE^PSJBCMA4(PSBREC(0),PSBREC(1)) S (X,Y)=0
16 Q
17 ;
18COMMENT ;
19 S PSBIEN="+1,"_PSBIEN_","
20 D VAL^PSBML(53.793,PSBIEN,.01,PSBREC(0))
21 S PSBFDA(53.793,PSBIEN,.02)=DUZ
22 S PSBFDA(53.793,PSBIEN,.03)=PSBNOW
23 D FILEIT^PSBML
24 Q
25 ;
26PRN ;
27 S PSBIEN=PSBIEN_","
28 D VAL^PSBML(53.79,PSBIEN,.22,PSBREC(0))
29 D FILEIT^PSBML
30 Q
31UPDATE ;
32 S PSBIEN=PSBIEN_","
33 I "^G^N^H^R^RM^S^C^I^"[U_PSBREC(0)_U D
34 .D VAL^PSBML(53.79,PSBIEN,.06,PSBNOW)
35 .D VAL^PSBML(53.79,PSBIEN,.07,"`"_DUZ)
36 .D VAL^PSBML(53.79,PSBIEN,.09,PSBREC(0))
37 .I $D(PSBREC(3)),PSBREC(3)]"" D VAL^PSBML(53.79,PSBIEN,.26,PSBREC(3))
38 D:PSBREC(1)]""
39 .I (PSBREC(0)="N"),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBREC(1)="Not Given: "_PSBREC(1)
40 .I ((PSBREC(0)="N")!(PSBREC(0)="G")),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM") S PSBREC(1)="Undo Remove: "_PSBREC(1)
41 .S:PSBREC(0)="H" PSBREC(1)="Held: "_PSBREC(1)
42 .S:PSBREC(0)="R" PSBREC(1)="Refused: "_PSBREC(1)
43 .S:PSBREC(0)="RM" PSBREC(1)="Removed: "_PSBREC(1)
44 .D VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(1))
45 .D VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
46 .D VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
47 S PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
48 I ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM"),((PSBREC(0)="N")!(PSBREC(0)="G")) D
49 .I '(($D(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIEN,.07,"I")=DUZ)) S RESULTS(0)="-1^Verify PSB MANAGER allocation" Q
50 .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
51 ..I PSBXDAT["Set to 'GIVEN'" D
52 ...S PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
53 ...F PSBYX=(PSBYY-2):-1:0 Q:PSBYX<1 I ^PSB(53.79,+PSBIEN,.9,PSBYX,0)["ACTION DATE/TIME Set to" S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYX,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":") Q
54 ...S PSBXDT=PSBXDATE F S PSBXDT=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT)) Q:PSBXDT="" D Q:+$G(RESULTS(0))<0
55 ....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" S RESULTS(0)="-1^Cannot UNDO! Order has GIVEN patch" Q
56 ...I '(+$G(RESULTS(0))<0) D S PSBGIVEN=1
57 ....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")
58 ..D:('(+$G(RESULTS(0))<0))&('PSBGIVEN)&($G(PSBXPTCH))&(PSBYY'>1)
59 ...S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYY,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":")
60 ...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
61 ;If set to not given then set dose given to 0
62 Q:(+$G(RESULTS(0))<0)
63 S:$G(PSBGIVEN) PSBREC(0)="G"
64 I PSBREC(0)="N",($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G") D:$D(^PSB(53.79,+PSBIEN,.5,0))
65 .S PSBX=0 F S PSBX=$O(^PSB(53.79,$P(PSBIEN,","),.5,PSBX)) Q:'(+PSBX) S $P(^PSB(53.79,$P(PSBIEN,","),.5,PSBX,0),"^",3)=0
66 I $G(PSBREC(2))]"" D VAL^PSBML(53.79,PSBIEN,.16,PSBREC(2))
67 S PSBOLDUZ=$P(^PSB(53.79,+PSBIEN,0),U,7),PSBOLSTS=$P(^PSB(53.79,+PSBIEN,0),U,9)
68 I $G(PSBREC(4))]"" D ; DD/SOL/ADD
69 .I PSBREC(0)="G"!(PSBREC(0)="I")!(PSBREC(0)="H")!(PSBREC(0)="R")!(PSBREC(0)="M") D ; Only apply if given or infusing
70 ..K ^PSB(53.79,+PSBIEN,.5),^PSB(53.79,+PSBIEN,.6),^PSB(53.79,+PSBIEN,.7)
71 ..F PSBCNT=4:1 Q:'$D(PSBREC(PSBCNT)) D
72 ...S Y=$P(PSBREC(PSBCNT),U)
73 ...S PSBDD=$S(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
74 ...Q:'PSBDD
75 ...S PSBIENS="+"_PSBCNT_","_PSBIEN
76 ...D VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
77 ...D VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
78 ...D VAL^PSBML(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4))
79 ...D:Y="DD" VAL^PSBML(PSBDD,PSBIENS,.04,$P(PSBREC(PSBCNT),U,5))
80 D FILEIT^PSBML
81 ; add audit for change of status
82 ; tell pharmacy if change of status on pharmacy generated UID
83 I $P($G(RESULTS(0)),U,1)=1 D
84 .S PSBUID=$P(^PSB(53.79,+PSBIEN,0),U,10) I PSBUID]"",PSBUID'["WS" D
85 ..S PSBON=$P(^PSB(53.79,+PSBIEN,.1),U,1)
86 ..S PSBDFN=$P(^PSB(53.79,+PSBIEN,0),U,1)
87 ..I PSBREC(0)="N" S PSBREC(0)="" D
88 ...M PSBAR=^PSB(53.79,+PSBIEN,.9)
89 ...S (PSBDN,X)="" F S X=$O(PSBAR(X),-1) Q:X=0!(PSBDN=1) D
90 ....I PSBAR(X,0)["ACTION STATUS",PSBAR(X,0)["deleted",PSBAR(X,0)'["GIVEN" D
91 .....S PSBTS=$P($P(PSBAR(X,0),"'",2),"'",1)
92 .....S PSBREC(0)=$S(PSBTS="HELD":"H",PSBTS="REFUSED":"R",PSBTS="REMOVED":"RM",PSBTS="MISSING":"M",1:""),PSBDN=1
93 ..I PSBREC(0)="" D VAL^PSBML(53.79,PSBIEN,.26,"") D CLEAN^DILF,UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
94 ..D EN^PSJBCMA3(PSBDFN,+PSBON,PSBUID,PSBREC(0),PSBNOW)
95 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))
96 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))
97 Q
Note: See TracBrowser for help on using the repository browser.