source: WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUOP1.m@ 701

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1PSUOP1 ;BIR/CFL - PSU PBM Outpatient Pharmacy Data Collection for Version 6.0 ;25 AUG 1998
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;
4 ;DBIAs
5 ; Reference to ^PSRX( file #52 supported by DBIA(s) 465, 2512, 2513
6EN ;Entry to data collection
7 K ^TMP($J)
8 D CMOPARY,ADLOOP
9 Q
10ADLOOP ;Loop through the AD cross reference
11 S X1=PSUSDT,X2=-31
12 D C^%DTC K %,%H,%T
13 S PSUFDT=X
14 F S PSUFDT=$O(^PSRX("AD",PSUFDT)) Q:PSUFDT=""!(PSUFDT\1>PSUEDT) D
15 .S PSURXIEN=""
16 .F S PSURXIEN=$O(^PSRX("AD",PSUFDT,PSURXIEN)) Q:PSURXIEN="" D
17 ..S PSUFIL=""
18 ..F S PSUFIL=$O(^PSRX("AD",PSUFDT,PSURXIEN,PSUFIL)) Q:PSUFIL="" D
19 ...Q:'$D(^PSRX(PSURXIEN,0))
20 ...K PSUTYP,PSUOP
21 ...S PSUFLN=PSUFIL
22 ...D COMVAR
23 ...S PSUCMOP="N"
24 ...;
25 ...; check for CMOP data
26 ...I $D(^PSRX(PSURXIEN,4,0)) D ARLOOP
27 ...I PSUCMOP="Y" Q ; record filed in subroutine
28 ...I (PSUFDT\1<PSUSDT) Q
29 ...S PSUTYP=$S(PSUFLN=0:"N",1:"R")
30 ...D GETDATA
31 ...D SETREC^PSUOP3
32 ..I $D(^PSRX(PSURXIEN,"P",0)),'$D(^XTMP(PSUOPSUB,"RXIEN",PSURXIEN)) D ADPLOOP
33 K ^TMP($J)
34 Q
35ARLOOP ;Check to see if CMOP Data exists for the reporting period
36 I $D(^TMP($J,PSURXIEN,PSUFLN)) D
37 .S PSUCMOP="Y"
38 .S PSUTYP=$S(PSUFLN=0:"N",1:"R")
39 .D GETDATA
40 .I (PSURELDT="")!(PSURELDT<PSUSDT)!(PSURELDT>PSUEDT) Q
41 .D SETREC^PSUOP3
42 Q
43ADPLOOP ;Get data for partial fills
44 S PSUPFN=0
45 F S PSUPFN=$O(^PSRX(PSURXIEN,"P",PSUPFN)) Q:'PSUPFN D
46 .S PSUCMOP="N"
47 .D COMVAR
48 .S PSUTYP="P"
49 .D GETPART
50 .Q:((PSUFD<PSUSDT)!(PSUFD>PSUEDT))
51 .D SETREC^PSUOP3
52 Q
53GETDATA ;Get the data for New Fills, Refills and Partial fills
54 I PSUTYP="N" D
55 .S PSUFD=PSUOP(22)
56 .S PSUDS=PSUOP(8)
57 .S PSUQTY=+PSUOP(7)
58 .S PSUDRCT=PSUOP(17)
59 .S PSURELDT=PSUOP(31)
60 .I PSURELDT'="" S PSURELDT=PSURELDT\1
61 .S PSUPRID=PSUOP(4)
62 .S PSUMW=PSUOP(11)
63 .S PSUDIVP=PSUOP(20)
64 .S PSUNDC=""
65 .I PSUCMOP="Y" D
66 ..S PSUNDC=$$VALI^PSUTL(52.01,"PSURXIEN,PSUFLN",4)
67 .S PSUNDC=$S(PSUNDC="":PSUOP(27),PSUNDC="":PSUDRUG(31),1:"No NDC")
68 .D PROVDR^PSUOP3
69 ;Get data for Refills
70 I PSUTYP="R" D K REC
71 .D GETS^PSUTL(52.1,"PSURXIEN,PSUFLN",".01;1;1.1;1.2;2;8;15;17","PSUREFIL","I")
72 .D MOVEI^PSUTL("PSUREFIL")
73 .S PSUFD=PSUREFIL(.01)
74 .S PSUPRID=PSUREFIL(15)
75 .S PSUMW=PSUREFIL(2)
76 .S PSUDIVP=PSUREFIL(8)
77 .S PSUDS=PSUREFIL(1.1)
78 .S PSUQTY=+PSUREFIL(1)
79 .S PSUDRCT=PSUREFIL(1.2)
80 .S PSURELDT=PSUREFIL(17)
81 .I PSURELDT'="" S PSURELDT=PSURELDT\1
82 .S PSURXP=PSUOP(3)
83 .S PSUDR=PSUOP(6)
84 .S PSUNDC=""
85 .I PSUCMOP="Y" D
86 ..S PSUNDC=$$VALI^PSUTL(52.01,"PSURXIEN,PSUFLN",4)
87 .I PSUNDC="" S PSUNDC=$$VALI^PSUTL(52.1,"PSURXIEN,PSUFLN",11)
88 .I PSUNDC="" S PSUNDC=$S(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
89 .D PROVDR^PSUOP3
90 Q
91GETPART ;Get data for Partial Fills
92 K PSUPART
93 D GETS^PSUTL(52.2,"PSURXIEN,PSUPFN",".01;.02;.04;.041;.042;.09;6;8","PSUPART","I")
94 D MOVEI^PSUTL("PSUPART")
95 S PSUFD=PSUPART(.01)
96 S PSUPRID=PSUPART(6)
97 S PSUMW=PSUPART(.02)
98 S PSUDIVP=PSUPART(.09)
99 S PSUDS=PSUPART(.041)
100 S PSUQTY=+PSUPART(.04)
101 S PSUDRCT=PSUPART(.042)
102 S PSURELDT=PSUPART(8)
103 I PSURELDT'="" S PSURELDT=PSURELDT\1
104 S PSUNDC=$$VALI^PSUTL(52.2,"PSURXIEN,PSUFLN",1)
105 I PSUNDC="" S PSUNDC=$S(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
106 D PROVDR^PSUOP3 ;Get shared variables
107 Q
108COMVAR ;Get the common variables
109 D GETS^PSUTL(52,PSURXIEN,".01;2;3;4;6;7;8;11;17;20;22;27;31","PSUOP","I")
110 D MOVEI^PSUTL("PSUOP")
111 S PSURXN=PSUOP(.01)
112 S DFN=PSUOP(2) D PID^VADPT
113 S PSUSSN=$TR(VA("PID"),"^-","")
114 S PSUWPC="" ;Patient counseling only exists for version 7.0
115 S PSUDR=PSUOP(6)
116 S PSURXP=PSUOP(3)
117 ;S PSUSIG=PSUOP(10)
118 D GETDRUG^PSUOP3
119 Q
120CMOPARY ;Loop through the "AR" cross reference and build CMOP array
121 S X1=PSUSDT,X2=-1
122 D C^%DTC K %,%H,%T
123 S PSUCDT=X
124 F S PSUCDT=$O(^PSRX("AR",PSUCDT)) Q:'PSUCDT D
125 .S PSUCRX=""
126 .F S PSUCRX=$O(^PSRX("AR",PSUCDT,PSUCRX)) Q:PSUCRX="" D
127 ..S PSUCLN=""
128 ..F S PSUCLN=$O(^PSRX("AR",PSUCDT,PSUCRX,PSUCLN)) Q:PSUCLN="" D
129 ...S ^TMP($J,PSUCRX,PSUCLN)=""
130 Q
Note: See TracBrowser for help on using the repository browser.