source: WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPFSU0.m@ 623

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

revised back to 6/30/08 version

File size: 4.4 KB
Line 
1PSOPFSU0 ;BIR/LE,AM - PFSS Get Account & Utilities ;08/09/93
2 ;;7.0;OUTPATIENT PHARMACY;**201**;DEC 1997
3 ;External reference SWSTAT^IBBAPI supported by DBIA 4663
4 ;External reference GETACCT^IBBAPI supported by DBIA 4664
5 ;External reference ^DG(40.8,"AD" supported by DBIA 2817
6 Q
7 ;
8GACT(PSORXN,PSOREF) ;ENTRY POINT: Called from PSON52; PSOR52, PSORN52. Get a PFSS acct ref
9 ; This routine is only called when the PFSS Switch is on.
10 ;
11 N I,J,PSOPFSAC,PSOPV1,PSODG,PSOZCL,PSODFN,PSORX,PSOPV2,PSODIV
12 ;for sending to an external billing system, get data from file 52, build arrays for IBB API call
13 I PSOREF=0 D GACTOF
14 I PSOREF>0 D GACTRF
15 ;Get general Rx data fields
16 S PSODIV=$$MCDIV(PSORXN,PSOREF)
17 S PSODFN=$$GET1^DIQ(52,PSORXN,"2","I")
18 S PSOPV1(2)="O",PSOPV1(50)=PSORXN
19 S PSOPV1(3)=$$CHLOC()
20 Q:PSOPV1(3)="" 0 ;can't do GETACCT if CHARGE LOCATION is null; this is to be address in subsequent PFSS project phase
21 ;request the PFSS Acct Rev
22 S PSOPFSAC=$$GETACCT^IBBAPI(PSODFN,"","A04","GACT;PSOPFSU0",.PSOPV1,"","",.PSODG,.PSOZCL,PSODIV,"")
23 ;Store the PFS Acct Ref with speed in mind
24 Q:PSOPFSAC<1 ""
25 I PSOREF=0 S $P(^PSRX(PSORXN,"PFS"),"^")=PSOPFSAC
26 I PSOREF>0 S $P(^PSRX(PSORXN,1,PSOREF,"PFS"),"^")=PSOPFSAC
27 Q PSOPFSAC
28 ;
29GACTOF ;Get orig fill data
30 D GETS^DIQ(52,PSORXN,"4;22","I","PSORX")
31 S PSOPV1(7)=$G(PSORX(52,PSORXN_",",4,"I")),PSOPV1(44)=$G(PSORX(52,PSORXN_",",22,"I"))
32 D GOC
33 Q
34 ;
35GACTRF ;Called from GACT. Get refill data
36 D GETS^DIQ(52.1,PSOREF_","_PSORXN,".01;15","I","PSORX")
37 S PSOPV1(7)=$G(PSORX(52.1,PSOREF_","_PSORXN_",","15","I"))
38 S PSOPV1(44)=$G(PSORX(52.1,PSOREF_","_PSORXN_",",".01","I"))
39 D GOC
40 Q
41 ;
42CHLOC() ;FIND CHARGE LOCATION
43 N CHLOC,CL,PDIV
44 I PSOREF=0 S PDIV=$$GET1^DIQ(52,PSORXN,"20","I") ;DIVISION
45 I PSOREF>0 S PDIV=$$GET1^DIQ(52.1,PSOREF_","_PSORXN_",","8","I")
46 S CHLOC=$$GET1^DIQ(59,PDIV,1007,"I") ;Charge location pointer
47 I CHLOC="" S CL="" D CLOK S:CL>0 CHLOC=CL
48 Q CHLOC
49 ;
50GOC ;Called from GACTOF and GACTRF. Parse OP classifications and ICD's. Don't send null values.
51 D GETS^DIQ(52,PSORXN,"52311*","I","PSORX")
52 F I=1:1 Q:'$D(PSORX(52.052311,I_","_PSORXN_",")) D
53 . S:PSORX(52.052311,I_","_PSORXN_",",".01","I")'="" PSODG(I,3)=PSORX(52.052311,I_","_PSORXN_",",".01","I"),PSODG(I,6)="W"
54 . I I=1 F J=1:1:7 Q:'$D(PSORX(52.052311,I_","_PSORXN_",",J,"I")) D
55 . . S:PSORX(52.052311,I_","_PSORXN_",",J,"I")'="" PSOZCL(J,2)=J,PSOZCL(J,3)=PSORX(52.052311,I_","_PSORXN_",",J,"I")
56 S:'$D(PSOZCL) PSOZCL="" S:'$D(PSODG) PSODG=""
57 Q
58 ;
59RPH(PSORXN,PSOREF) ;API entry point
60 ; Inputs: PSORXN = prescription IEN, PSOREF = fill number
61 ; Outputs: PSORPH = rel pharm IEN ^ user IEN who performed last activity or rel pharm iF no activity entries^
62 ; IB Service Section pointer from file 59
63 ; Returns null values when the Rx is not released or the input values are invalid (i.e. "^^").
64 N I,II,IBSS,DIV,PSORPH,PSOEDPH,PSOA,PSORDT,PSOOK,PSOA,DATA
65 S PSOOK=$$CHKRX(PSORXN,PSOREF) Q:PSOOK'=1 "^^"
66 I 'PSOREF D GETS^DIQ(52,PSORXN,"20;23;31","I","DATA")
67 E D GETS^DIQ(52.1,PSOREF_","_PSORXN,"4;8;17","I","DATA")
68 I PSOREF=0 D
69 . S PSORPH=+$G(DATA(52,PSORXN_",",23,"I")) S:PSORPH=0 PSORPH=""
70 . S DIV=+$G(DATA(52,PSORXN_",",20,"I"))
71 . S PSORDT=+$G(DATA(52,PSORXN_",",31,"I"))
72 I PSOREF>0 D
73 . S PSORPH=+$G(DATA(52.1,PSOREF_","_PSORXN_",",4,"I")) S:PSORPH=0 PSORPH=""
74 . S DIV=+$G(DATA(52.1,PSOREF_","_PSORXN_",",8,"I"))
75 . S PSORDT=+$G(DATA(52.1,PSOREF_","_PSORXN_",",17,"I"))
76 Q:PSORDT=0 "^^"
77 ;last activity - get last one with a user
78 I $D(^PSRX(PSORXN,"A",0)) S PSOA=$P(^PSRX(PSORXN,"A",0),"^",3) D
79 . F II=PSOA:-1:1 S PSOEDPH=$$GET1^DIQ(52.3,II_","_PSORXN_",",".03","I") Q:PSOEDPH'=""
80 ;get IB Service Section (requested by Ed Z. on 6/29/05)
81 S IBSS=$P($G(^PS(59,DIV,"IB")),"^")
82 S:'$G(PSOEDPH) PSOEDPH=PSORPH
83 S PSORPH=$G(PSORPH)_"^"_$G(PSOEDPH)_"^"_$G(IBSS)
84 Q PSORPH
85 ;
86CHKRX(PSORX,PSOF) ;validates Rx & fill. 0=not valid, 1=valid, 2=refill not valid
87 Q:PSORX=""!(PSOF="") 0
88 Q:'$D(^PSRX(PSORX)) 0
89 Q:PSOF>0&('$D(^PSRX(PSORX,1,PSOF))) 2
90 Q 1
91 ;
92MCDIV(RX,FILL) ;Get MC DIVISION from the Rx/Fill
93 N DIV,INST
94 ; outpatient division
95 I 'FILL S DIV=$$GET1^DIQ(52,RX,20,"I")
96 E S DIV=$$GET1^DIQ(52.1,FILL_","_RX,8,"I")
97 Q:'DIV ""
98 ; related institution
99 S INST=$$GET1^DIQ(59,DIV,100,"I") Q:'INST ""
100 S DIV=$O(^DG(40.8,"AD",INST,0)) ; pointer to medical center division
101 Q DIV
102 ;
103CLOK ;
104 N I S I=0 F S I=$O(^PS(59,I)) Q:'I!(CL>0) D
105 . I $S('$D(^PS(59,I,"I")):1,'+$P(^("I"),"^"):1,DT'>+$P(^("I"),"^"):1,1:0) S CL=$P($G(^PS(59,I,"PFS")),"^")
106 Q
107 ;
Note: See TracBrowser for help on using the repository browser.