source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUV1.m@ 1499

PSUV1 ;BIR/CFL - Extract Data of PBM IV Module ;25 AUG 1998
 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
 ;DBIAs
 ; Reference to file #55   supported by DBIA 2497
 ; Reference to file #59.5 supported by DBIA 2499
 ; Reference to file #40.8 supported by DBIA 2438
 ; Reference to file #7    supported by DBIA 2495
 ; Reference to file #49   supported by DBIA 10093
 ; Reference to file #52.6 supported by DBIA 436
 ; Reference to file #50   supported by DBIA 221
 ; Reference to file #52.7 supported by DBIA 437
 ; Reference to file #2    supported by DBIA 10035 and 2701
 ; Reference to file #200  supported by DBIA 10060
 ;
IVDATA ;Loop through IV data
 N PSUDOC1
 K PSUSSNA,PSUORDA
 ; *34 |==>
 S PSUIVDT=PSUSDT\1-.0001 ;use 1st day of extract for 'stop date' scan
 S PSUTEDT=PSUEDT\1+.2359
 F  S PSUIVDT=$O(^PS(55,"AIV",PSUIVDT)) Q:'PSUIVDT  D
 .S PSUPDA=""
 .F  S PSUPDA=$O(^PS(55,"AIV",PSUIVDT,PSUPDA)) Q:'PSUPDA  D
 ..S PSUODA=""
 ..F  S PSUODA=$O(^PS(55,"AIV",PSUIVDT,PSUPDA,PSUODA)) Q:'PSUODA  D
 ...S ^XTMP("PSU_"_PSUJOB,"PSUHLD",PSUODA)=""   ;should be the D0's for file 55.01 ; <==| *34
 ...S COUNT=0
 ...S PSUDIV=""
 ...K PSUIV
 ...; screen test patients
 ...Q:$$TESTPAT^PSUTL1(PSUPDA)
 ...S XX=$$VALI^PSUTL(55.01,"PSUPDA,PSUODA",.02) Q:XX>PSUTEDT  ;*34
 ...K PSUIV ;*34
 ...D GETS^PSUTL(55.01,"PSUPDA,PSUODA",".01;.02;.03;.04;.06;.08;.09;.22;104;106;108","PSUIV","I")
 ...;.01-Order num;.02-Start Dt;.03-Stop Dt;.04-Type;.06-Provider
 ...;104-Ward;106-Chemotherapy Type;108-Intermittent Syringe
 ...Q:'$D(PSUIV)
 ...;VMP OIFO BAY PINES;ELR;PSU*3*35 ADDED NEXT LINE
 ...Q:$G(PSUIV(.06,"I"))'>0
 ...S ^XTMP("PSU_"_PSUJOB,"PSUPIEN",PSUPDA)=""     ;Patient IEN's ;*34
 ...D MOVEI^PSUTL("PSUIV")
 ...S PSUIV(.02)=PSUIV(.02)\1
 ...S PSUIV(.03)=PSUIV(.03)\1
 ...I PSUIV(.22)'="" S PSUDIV=$$VALI^PSUTL(59.5,PSUIV(.22),.02)
 ...S PSUFAC=$$VALI^PSUTL(40.8,PSUDIV,1) S:PSUFAC="" PSUFAC=PSUSNDR
 ...S PSUFAC(PSUFAC)=""
 ...S PSUOUTP=$S(PSUIV(104)=.5:"Y",1:"N")
 ...S DFN=PSUPDA D PID^VADPT
 ...S PSUSSN=$TR(VA("PID"),"^-","")
 ...D ICN
 ...K PSUDOC
 ...D GETS^PSUTL(200,"PSUIV(.06)","9;29;53.5","PSUDOC","I")
 ...D MOVEI^PSUTL("PSUDOC")
 ...I $G(PSUDOC(9))="" S PSUVSSN1=999999999
 ...I $G(PSUDOC(9))'="" S PSUVSSN1=PSUDOC(9)
 ...S ^XTMP("PSU_"_PSUJOB,"PSUPDR",PSUVSSN1,PSUIV(.06))=""
 ...S (PSUPCLS,PSUSP1,PSUSP2)=""
 ...I $D(PSUDOC(53.5)),PSUDOC(53.5)'="" D
 ....S PSUPCLS=$$VALI^PSUTL(7,PSUDOC(53.5),1)
 ....I PSUPCLS="" S PSUPCLS=$$VALI^PSUTL(7,PSUDOC(53.5),.01)
 ...S PSUPSV=$S($L($G(PSUDOC(29))):$$VAL^PSUTL(49,PSUDOC(29),.01),1:"")
 ...S PSUPSV=$$UPPER^PSUTL(PSUPSV),PSUSERV=""
 ...I $L(PSUPSV),$D(PSECT(PSUPSV)) S PSUSERV=PSECT(PSUPSV)
 ...S SPECPTR=$$GET^XUA4A72(PSUIV(.06),PSUIVDT)
 ...S PSUSP1=$P($G(SPECPTR),U,3),PSUSP2=$P($G(SPECPTR),U,4)
 ...D OCCAMT
 ...I PSUFND D
 ....D GETRATE^PSUV2(PSUIV(.04))
 ....D SETTOT
 ....S RECTYP=""
 ....D ADDTIV
 ....D SOLUTN
 I $D(^XTMP(PSUIVSUB,"RECORDS")) D SETSUM^PSUV2
 Q
 ;
ICN ;Find patient ICN 
 ;
 N PSUPICN,PSUPICN1,PSUICN
 S PSUPTN=0
 I $G(PSUSSN),PSUSSN'="" D
 .F  S PSUPTN=$O(^DPT("SSN",PSUSSN,PSUPTN)) Q:PSUPTN=""  D
 ..S PSUPICN1=$$GETICN^MPIF001(PSUPTN) D
 ...I PSUPICN1'[-1 D
 ....S ^XTMP("PSU_"_PSUJOB,"PSUPICN")=PSUPICN1
 ...I PSUPICN1[-1 S ^XTMP("PSU_"_PSUJOB,"PSUPICN")=""
 Q
 ;
 ;
OCCAMT ;Calculate the number of dispensing occurrences
 S (PSUFND,PSUDISP,PSUPULL,OCC,PSUDISPT,PSURECT,PSUDEST,PSUCAN)=0
 F  S OCC=$O(^PS(55,PSUPDA,"IV",PSUODA,"LAB",OCC)) Q:'OCC  D
 .K PSUOCC
 .D GETS^PSUTL(55.1111,"PSUPDA,PSUODA,OCC","1;2;4;6","PSUOCC","I")
 .D MOVEI^PSUTL("PSUOCC")
 .S PSUOCC(1)=PSUOCC(1)\1
 .I PSUOCC(1)<PSUSDT!(PSUOCC(1)>PSUTEDT) Q  ;*34
 .S PSUFND=1
 .I $G(PSUOCC(6))=1,$G(PSUOCC(2))=1 D
 ..S PSUDISP=PSUDISP+$G(PSUOCC(4))
 ..S PSUDISPT=PSUDISP                        ;Total IV dispensed
 ..S PSUPULL=PSUPULL+$G(PSUOCC(4))
 ..S ^XTMP(PSUIVSUB,"TYPE_"_PSUIV(.04),PSUFAC)=PSUOCC(4)+$G(^XTMP(PSUIVSUB,"TYPE_"_PSUIV(.04),PSUFAC))
 ..I PSUOUTP="Y" D  ; Total outpatient IV's dispensed
 ...S ^XTMP(PSUIVSUB,"ODISP",PSUFAC)=$G(^XTMP(PSUIVSUB,"ODISP",PSUFAC))+PSUOCC(4)
 .;I PSUOCC(2)=2!(PSUOCC(2)=4) S PSUDISP=PSUDISP-PSUOCC(4)
 .I PSUOCC(6)=1,PSUOCC(2)=2 D
 ..S PSURECT=$G(PSURECT)+PSUOCC(4)               ;Total IV Recycled
 .I PSUOCC(6)=1,PSUOCC(2)=3 D
 ..S PSUDEST=$G(PSUDEST)+PSUOCC(4)               ;Total IV Destroyed
 .I PSUOCC(6)=1,PSUOCC(2)=4 D
 ..S PSUCAN=$G(PSUCAN)+PSUOCC(4)                 ;Total IV Cancelled
 .I PSUOCC(6)=1 D
 ..I (PSUOCC(2)=2)!(PSUOCC(2)=4) S PSUDISP=PSUDISP-PSUOCC(4) ;Net disp
 Q
SETTOT ;Set totals
 ; Total number of IV's ordered
 S ^XTMP(PSUIVSUB,"ORD",PSUFAC)=$G(^XTMP(PSUIVSUB,"ORD",PSUFAC))+1
 ; Total number of IV patients
 I '$D(^XTMP(PSUIVSUB,"PAT",PSUSSN,PSUFAC)) D
 .S ^XTMP(PSUIVSUB,"SSN",PSUFAC)=$G(^XTMP(PSUIVSUB,"SSN",PSUFAC))+1
 .S ^XTMP(PSUIVSUB,"PAT",PSUSSN,PSUFAC)=""
 .S PSUDIV=PSUFAC D GETDIV^PSUV3 I PSUDIVNM'="" D
 ..S ^XTMP("PSU_"_PSUJOB,"PSUDIV",PSUDIVNM,PSUSSN)=""  ;Pt demo summary
 .I PSUDIVNM="" S ^XTMP("PSU_"_PSUJOB,"PSUDIV",PSUDIV,PSUSSN)=""
 I PSUOUTP="Y" D
 .; Total outpatient IV's ordered
 .S ^XTMP(PSUIVSUB,"OORD",PSUFAC)=$G(^XTMP(PSUIVSUB,"OORD",PSUFAC))+1
 Q
ADDTIV ;Loop through each additive
 S (PSUNITS,ADTIV)=0
 F  S ADTIV=$O(^PS(55,PSUPDA,"IV",PSUODA,"AD",ADTIV)) Q:'ADTIV  D
 .K PSUADDTV,PSUGNRIC,PSUADD
 .D GETS^PSUTL(55.02,"PSUPDA,PSUODA,ADTIV",".01;.02","PSUADDTV","I")
 .D MOVEI^PSUTL("PSUADDTV")
 .D GETS^PSUTL(52.6,"PSUADDTV(.01)",".01;1;7","PSUGNRIC","I")
 .D MOVEI^PSUTL("PSUGNRIC")
 .S PSUPNAM=PSUGNRIC(.01)
 .S PSUDGU=$$VAL^PSUTL(52.6,PSUADDTV(.01),2)
 .S PSUDGDA=PSUGNRIC(1)
 .D GETS^PSUTL(50,"PSUDGDA",".01;2;20;21;22;25;31;51;52;3","PSUADD","I")
 .D MOVEI^PSUTL("PSUADD")
 .S PSUGNM=PSUADD(.01)
 .S PSUDCLS=PSUADD(2)
 .S PSUPRNM=PSUADD(21)
 .S PSUNDC=PSUADD(31)
 .S PSUNFI=PSUADD(51)
 .S PSUNADR=PSUADD(20)
 .S PSUNDCL=PSUADD(22)
 .S PSUDEA=PSUADD(3)
 .S PSUNAF=$S(PSUADD(52):"N/F",1:"")
 .D SETVAR
 .S PSUSTRN=+PSUADDTV(.02)
 .;
 .;DAM  Add AMIS Additive data
 .N PSUTDSP1
 .S PSUTDSP1=$G(PSUDISPT)*PSUSTRN       ;Total Additive units dispens
 .;
 .N PSURCY1
 .S PSURCY1=$G(PSURECT)*PSUSTRN         ;Total Additive units recycled
 .;
 .N PSUDES1
 .S PSUDES1=$G(PSUDEST)*PSUSTRN      ;Total Additive units destroyed
 .;
 .N PSUCAN1
 .S PSUCAN1=$G(PSUCAN)*PSUSTRN         ;Total Additive units cancelled
 .;END DAM
 .S PSUNITS=PSUDISP*PSUSTRN
 .S PSUBAGS=PSUPULL*PSUSTRN
 .S PSUDCST=PSUGNRIC(7)
 .S RECIND="A"
 .D CALC
 .D SETREC^PSUV2
 .D SETDRUG^PSUV2
 Q
SOLUTN ;Loop through each solution
 S (PSUNITS,SOLDA)=0 F  S SOLDA=$O(^PS(55,PSUPDA,"IV",PSUODA,"SOL",SOLDA)) Q:'SOLDA  D
 .K PSUSOL,GENRIC,SOLDRUG
 .D GETS^PSUTL(55.11,"PSUPDA,PSUODA,SOLDA",".01;1","PSUSOL","I")
 .D MOVEI^PSUTL("PSUSOL")
 .D GETS^PSUTL(52.7,"PSUSOL(.01)",".01;1;7","GENRIC","I")
 .D MOVEI^PSUTL("GENRIC")
 .S PSUPNAM=GENRIC(.01)
 .S PSUDGU="ML"
 .S PSUDGDA=GENRIC(1)
 .D GETS^PSUTL(50,"PSUDGDA",".01;2;20;21;22;25;31;51;52;3","SOLDRUG","I")
 .D MOVEI^PSUTL("SOLDRUG")
 .S PSUGNM=SOLDRUG(.01)
 .S PSUDCLS=SOLDRUG(2)
 .S PSUPRNM=SOLDRUG(21)
 .S PSUNDC=SOLDRUG(31)
 .S PSUNFI=SOLDRUG(51)
 .S PSUNADR=SOLDRUG(20)
 .S PSUNDCL=SOLDRUG(22)
 .S PSUDEA=SOLDRUG(3)
 .S PSUNAF=$S(SOLDRUG(52):"N/F",1:"")
 .D SETVAR
 .S VOLUME=+PSUSOL(1)
 .;
 .;DAM ADD AMIS SOLUTION DATA
 .N PSUTSOL1
 .S PSUTSOL1=$G(PSUDISPT)*VOLUME    ;Total Solution units dispense
 .;
 .N PSUTRS1
 .S PSUTRS1=$G(PSURECT)*VOLUME       ;Total Solution units recycl
 .;
 .N PSUTDS1
 .S PSUTDS1=$G(PSUDEST)*VOLUME     ;Total Solution units destroyed
 .;
 .N PSUTCS1
 .S PSUTCS1=$G(PSUCAN)*VOLUME        ;Total Solution units cancelled
 .;END DAM
 .S PSUNITS=PSUDISP*VOLUME
 .S PSUBAGS=PSUPULL*VOLUME
 .S PSUDCST=GENRIC(7)
 .S RECIND="S"
 .D CALC
 .D SETREC^PSUV2
 .D SETDRUG^PSUV2
 Q
SETVAR ;Setup common variables for IV Additives and Solutions
 I PSUGNM="" S PSUGNM="UNKNOWN GENERIC NAME"
 I PSUPRNM="" S PSUPRNM="UNKNOWN VA PRODUCT NAME"
 I PSUNDC="" S PSUNDC="No NDC"
 I PSUNFI=1 S PSUNFI="N/F"
 S (PSIVNFI,PSIVNFR)=""
 I $$VERSION^XPDUTL("PSN")'<4 D
 .S PSIVNFI=$$FORMI^PSNAPIS(PSUNADR,PSUNDCL)
 .S PSIVNFR=$$FORMR^PSNAPIS(PSUNADR,PSUNDCL)>0
 Q
CALC ;Do calculations for additives and solutions
 S ^XTMP(PSUIVSUB,"CST",PSUFAC)=(PSUNITS*PSUDCST)+$G(^XTMP(PSUIVSUB,"CST",PSUFAC))
 S RECTYP=""
 S COUNT=COUNT+1
 S:COUNT=1 RECTYP="P"
 I PSUOUTP="Y" D
 .S ^XTMP(PSUIVSUB,"OCST",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"OCST",PSUFAC))
 I PSUIV(.04)="P" D
 .S ^XTMP(PSUIVSUB,"SPIG",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"SPIG",PSUFAC))
 I PSUIV(.04)="A" D
 .S ^XTMP(PSUIVSUB,"SADM",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"SADM",PSUFAC))
 I PSUIV(.04)="H" D
 .S ^XTMP(PSUIVSUB,"SHYP",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"SHYP",PSUFAC))
 I PSUIV(.04)="S" D
 .S ^XTMP(PSUIVSUB,"SSYR",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"SSYR",PSUFAC))
 I PSUIV(.04)="C" D
 .S ^XTMP(PSUIVSUB,"SCHEM",PSUFAC)=(PSUDCST*PSUBAGS)+$G(^XTMP(PSUIVSUB,"SCHEM",PSUFAC))
 Q