PSUOP1.m

PSUOP1 ;BIR/CFL - PSU PBM Outpatient Pharmacy Data Collection for Version 6.0 ;25 AUG 1998

 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005

 ;

 ;DBIAs

 ; Reference to ^PSRX( file #52 supported by DBIA(s) 465, 2512, 2513

EN ;Entry to data collection

 K ^TMP($J)

 D CMOPARY,ADLOOP

 Q

ADLOOP ;Loop through the AD cross reference

 S X1=PSUSDT,X2=-31

 D C^%DTC K %,%H,%T

 S PSUFDT=X

 F  S PSUFDT=$O(^PSRX("AD",PSUFDT)) Q:PSUFDT=""!(PSUFDT\1>PSUEDT)  D

 .S PSURXIEN=""

 .F  S PSURXIEN=$O(^PSRX("AD",PSUFDT,PSURXIEN)) Q:PSURXIEN=""  D

 ..S PSUFIL=""

 ..F  S PSUFIL=$O(^PSRX("AD",PSUFDT,PSURXIEN,PSUFIL)) Q:PSUFIL=""  D

 ...Q:'$D(^PSRX(PSURXIEN,0))

 ...K PSUTYP,PSUOP

 ...S PSUFLN=PSUFIL

 ...D COMVAR

 ...S PSUCMOP="N"

 ...;

 ...; check for CMOP data

 ...I $D(^PSRX(PSURXIEN,4,0)) D ARLOOP

 ...I PSUCMOP="Y" Q  ; record filed in subroutine

 ...I (PSUFDT\1<PSUSDT) Q

 ...S PSUTYP=$S(PSUFLN=0:"N",1:"R")

 ...D GETDATA

 ...D SETREC^PSUOP3

 ..I $D(^PSRX(PSURXIEN,"P",0)),'$D(^XTMP(PSUOPSUB,"RXIEN",PSURXIEN)) D ADPLOOP

 K ^TMP($J)

 Q

ARLOOP ;Check to see if CMOP Data exists for the reporting period

 I $D(^TMP($J,PSURXIEN,PSUFLN)) D 

 .S PSUCMOP="Y"

 .S PSUTYP=$S(PSUFLN=0:"N",1:"R")

 .D GETDATA

 .I (PSURELDT="")!(PSURELDT<PSUSDT)!(PSURELDT>PSUEDT) Q

 .D SETREC^PSUOP3

 Q

ADPLOOP ;Get data for partial fills

 S PSUPFN=0

 F  S PSUPFN=$O(^PSRX(PSURXIEN,"P",PSUPFN)) Q:'PSUPFN  D

 .S PSUCMOP="N"

 .D COMVAR

 .S PSUTYP="P"

 .D GETPART

 .Q:((PSUFD<PSUSDT)!(PSUFD>PSUEDT))

 .D SETREC^PSUOP3

 Q

GETDATA ;Get the data for New Fills, Refills and Partial fills

 I PSUTYP="N" D

 .S PSUFD=PSUOP(22)

 .S PSUDS=PSUOP(8)

 .S PSUQTY=+PSUOP(7)

 .S PSUDRCT=PSUOP(17)

 .S PSURELDT=PSUOP(31)

 .I PSURELDT'="" S PSURELDT=PSURELDT\1

 .S PSUPRID=PSUOP(4)

 .S PSUMW=PSUOP(11)

 .S PSUDIVP=PSUOP(20)

 .S PSUNDC=""

 .I PSUCMOP="Y" D

 ..S PSUNDC=$$VALI^PSUTL(52.01,"PSURXIEN,PSUFLN",4)

 .S PSUNDC=$S(PSUNDC="":PSUOP(27),PSUNDC="":PSUDRUG(31),1:"No NDC")

 .D PROVDR^PSUOP3

 ;Get data for Refills

 I PSUTYP="R" D  K REC

 .D GETS^PSUTL(52.1,"PSURXIEN,PSUFLN",".01;1;1.1;1.2;2;8;15;17","PSUREFIL","I")

 .D MOVEI^PSUTL("PSUREFIL")

 .S PSUFD=PSUREFIL(.01)

 .S PSUPRID=PSUREFIL(15)

 .S PSUMW=PSUREFIL(2)

 .S PSUDIVP=PSUREFIL(8)

 .S PSUDS=PSUREFIL(1.1)

 .S PSUQTY=+PSUREFIL(1)

 .S PSUDRCT=PSUREFIL(1.2)

 .S PSURELDT=PSUREFIL(17)

 .I PSURELDT'="" S PSURELDT=PSURELDT\1

 .S PSURXP=PSUOP(3)

 .S PSUDR=PSUOP(6)

 .S PSUNDC=""

 .I PSUCMOP="Y" D

 ..S PSUNDC=$$VALI^PSUTL(52.01,"PSURXIEN,PSUFLN",4)

 .I PSUNDC="" S PSUNDC=$$VALI^PSUTL(52.1,"PSURXIEN,PSUFLN",11)

 .I PSUNDC="" S PSUNDC=$S(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")

 .D PROVDR^PSUOP3

 Q

GETPART ;Get data for Partial Fills

 K PSUPART

 D GETS^PSUTL(52.2,"PSURXIEN,PSUPFN",".01;.02;.04;.041;.042;.09;6;8","PSUPART","I")

 D MOVEI^PSUTL("PSUPART")

 S PSUFD=PSUPART(.01)

 S PSUPRID=PSUPART(6)

 S PSUMW=PSUPART(.02)

 S PSUDIVP=PSUPART(.09)

 S PSUDS=PSUPART(.041)

 S PSUQTY=+PSUPART(.04)

 S PSUDRCT=PSUPART(.042)

 S PSURELDT=PSUPART(8)

 I PSURELDT'="" S PSURELDT=PSURELDT\1

 S PSUNDC=$$VALI^PSUTL(52.2,"PSURXIEN,PSUFLN",1)

 I PSUNDC="" S PSUNDC=$S(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")

 D PROVDR^PSUOP3  ;Get shared variables

 Q

COMVAR ;Get the common variables

 D GETS^PSUTL(52,PSURXIEN,".01;2;3;4;6;7;8;11;17;20;22;27;31","PSUOP","I")

 D MOVEI^PSUTL("PSUOP")

 S PSURXN=PSUOP(.01)

 S DFN=PSUOP(2) D PID^VADPT

 S PSUSSN=$TR(VA("PID"),"^-","")

 S PSUWPC="" ;Patient counseling only exists for version 7.0

 S PSUDR=PSUOP(6)

 S PSURXP=PSUOP(3)

 ;S PSUSIG=PSUOP(10)

 D GETDRUG^PSUOP3

 Q

CMOPARY ;Loop through the "AR" cross reference and build CMOP array

 S X1=PSUSDT,X2=-1

 D C^%DTC K %,%H,%T

 S PSUCDT=X

 F  S PSUCDT=$O(^PSRX("AR",PSUCDT)) Q:'PSUCDT  D

 .S PSUCRX=""

 .F  S PSUCRX=$O(^PSRX("AR",PSUCDT,PSUCRX)) Q:PSUCRX=""  D

 ..S PSUCLN=""

 ..F  S PSUCLN=$O(^PSRX("AR",PSUCDT,PSUCRX,PSUCLN)) Q:PSUCLN=""  D

 ...S ^TMP($J,PSUCRX,PSUCLN)=""

 Q

PSUOP1    ;BIR/CFL - PSU PBM Outpatient Pharmacy Data Collection for Version 6.0 ;25 AUG 1998

 +1       ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005

 +2       ;

 +3       ;DBIAs

 +4       ; Reference to ^PSRX( file #52 supported by DBIA(s) 465, 2512, 2513

EN        ;Entry to data collection

 +1        KILL ^TMP($JOB)

 +2        DO CMOPARY

           DO ADLOOP

 +3        QUIT 

ADLOOP    ;Loop through the AD cross reference

 +1        SET X1=PSUSDT

           SET X2=-31

 +2        DO C^%DTC

           KILL %,%H,%T

 +3        SET PSUFDT=X

 +4        FOR 

               SET PSUFDT=$ORDER(^PSRX("AD",PSUFDT))

               IF PSUFDT=""!(PSUFDT\1>PSUEDT)

                   QUIT 

               Begin DoDot:1

 +5                SET PSURXIEN=""

 +6                FOR 

                       SET PSURXIEN=$ORDER(^PSRX("AD",PSUFDT,PSURXIEN))

                       IF PSURXIEN=""

                           QUIT 

                       Begin DoDot:2

 +7                        SET PSUFIL=""

 +8                        FOR 

                               SET PSUFIL=$ORDER(^PSRX("AD",PSUFDT,PSURXIEN,PSUFIL))

                               IF PSUFIL=""

                                   QUIT 

                               Begin DoDot:3

 +9                                IF '$DATA(^PSRX(PSURXIEN,0))

                                       QUIT 

 +10                               KILL PSUTYP,PSUOP

 +11                               SET PSUFLN=PSUFIL

 +12                               DO COMVAR

 +13                               SET PSUCMOP="N"

 +14      ;

 +15      ; check for CMOP data

 +16                               IF $DATA(^PSRX(PSURXIEN,4,0))

                                       DO ARLOOP

 +17      ; record filed in subroutine

                                   IF PSUCMOP="Y"

                                       QUIT 

 +18                               IF (PSUFDT\1<PSUSDT)

                                       QUIT 

 +19                               SET PSUTYP=$SELECT(PSUFLN=0:"N",1:"R")

 +20                               DO GETDATA

 +21                               DO SETREC^PSUOP3

                               End DoDot:3

 +22                       IF $DATA(^PSRX(PSURXIEN,"P",0))

                               IF '$DATA(^XTMP(PSUOPSUB,"RXIEN",PSURXIEN))

                                   DO ADPLOOP

                       End DoDot:2

               End DoDot:1

 +23       KILL ^TMP($JOB)

 +24       QUIT 

ARLOOP    ;Check to see if CMOP Data exists for the reporting period

 +1        IF $DATA(^TMP($JOB,PSURXIEN,PSUFLN))

               Begin DoDot:1

 +2                SET PSUCMOP="Y"

 +3                SET PSUTYP=$SELECT(PSUFLN=0:"N",1:"R")

 +4                DO GETDATA

 +5                IF (PSURELDT="")!(PSURELDT<PSUSDT)!(PSURELDT>PSUEDT)

                       QUIT 

 +6                DO SETREC^PSUOP3

               End DoDot:1

 +7        QUIT 

ADPLOOP   ;Get data for partial fills

 +1        SET PSUPFN=0

 +2        FOR 

               SET PSUPFN=$ORDER(^PSRX(PSURXIEN,"P",PSUPFN))

               IF 'PSUPFN

                   QUIT 

               Begin DoDot:1

 +3                SET PSUCMOP="N"

 +4                DO COMVAR

 +5                SET PSUTYP="P"

 +6                DO GETPART

 +7                IF ((PSUFD<PSUSDT)!(PSUFD>PSUEDT))

                       QUIT 

 +8                DO SETREC^PSUOP3

               End DoDot:1

 +9        QUIT 

GETDATA   ;Get the data for New Fills, Refills and Partial fills

 +1        IF PSUTYP="N"

               Begin DoDot:1

 +2                SET PSUFD=PSUOP(22)

 +3                SET PSUDS=PSUOP(8)

 +4                SET PSUQTY=+PSUOP(7)

 +5                SET PSUDRCT=PSUOP(17)

 +6                SET PSURELDT=PSUOP(31)

 +7                IF PSURELDT'=""

                       SET PSURELDT=PSURELDT\1

 +8                SET PSUPRID=PSUOP(4)

 +9                SET PSUMW=PSUOP(11)

 +10               SET PSUDIVP=PSUOP(20)

 +11               SET PSUNDC=""

 +12               IF PSUCMOP="Y"

                       Begin DoDot:2

 +13                       SET PSUNDC=$$VALI^PSUTL(52.01,"PSURXIEN,PSUFLN",4)

                       End DoDot:2

 +14               SET PSUNDC=$SELECT(PSUNDC="":PSUOP(27),PSUNDC="":PSUDRUG(31),1:"No NDC")

 +15               DO PROVDR^PSUOP3

               End DoDot:1

 +16      ;Get data for Refills

 +17       IF PSUTYP="R"

               Begin DoDot:1

 +18               DO GETS^PSUTL(52.1,"PSURXIEN,PSUFLN",".01;1;1.1;1.2;2;8;15;17","PSUREFIL","I")

 +19               DO MOVEI^PSUTL("PSUREFIL")

 +20               SET PSUFD=PSUREFIL(.01)

 +21               SET PSUPRID=PSUREFIL(15)

 +22               SET PSUMW=PSUREFIL(2)

 +23               SET PSUDIVP=PSUREFIL(8)

 +24               SET PSUDS=PSUREFIL(1.1)

 +25               SET PSUQTY=+PSUREFIL(1)

 +26               SET PSUDRCT=PSUREFIL(1.2)

 +27               SET PSURELDT=PSUREFIL(17)

 +28               IF PSURELDT'=""

                       SET PSURELDT=PSURELDT\1

 +29               SET PSURXP=PSUOP(3)

 +30               SET PSUDR=PSUOP(6)

 +31               SET PSUNDC=""

 +32               IF PSUCMOP="Y"

                       Begin DoDot:2

 +33                       SET PSUNDC=$$VALI^PSUTL(52.01,"PSURXIEN,PSUFLN",4)

                       End DoDot:2

 +34               IF PSUNDC=""

                       SET PSUNDC=$$VALI^PSUTL(52.1,"PSURXIEN,PSUFLN",11)

 +35               IF PSUNDC=""

                       SET PSUNDC=$SELECT(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")

 +36               DO PROVDR^PSUOP3

               End DoDot:1

               KILL REC

 +37       QUIT 

GETPART   ;Get data for Partial Fills

 +1        KILL PSUPART

 +2        DO GETS^PSUTL(52.2,"PSURXIEN,PSUPFN",".01;.02;.04;.041;.042;.09;6;8","PSUPART","I")

 +3        DO MOVEI^PSUTL("PSUPART")

 +4        SET PSUFD=PSUPART(.01)

 +5        SET PSUPRID=PSUPART(6)

 +6        SET PSUMW=PSUPART(.02)

 +7        SET PSUDIVP=PSUPART(.09)

 +8        SET PSUDS=PSUPART(.041)

 +9        SET PSUQTY=+PSUPART(.04)

 +10       SET PSUDRCT=PSUPART(.042)

 +11       SET PSURELDT=PSUPART(8)

 +12       IF PSURELDT'=""

               SET PSURELDT=PSURELDT\1

 +13       SET PSUNDC=$$VALI^PSUTL(52.2,"PSURXIEN,PSUFLN",1)

 +14       IF PSUNDC=""

               SET PSUNDC=$SELECT(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")

 +15      ;Get shared variables

           DO PROVDR^PSUOP3

 +16       QUIT 

COMVAR    ;Get the common variables

 +1        DO GETS^PSUTL(52,PSURXIEN,".01;2;3;4;6;7;8;11;17;20;22;27;31","PSUOP","I")

 +2        DO MOVEI^PSUTL("PSUOP")

 +3        SET PSURXN=PSUOP(.01)

 +4        SET DFN=PSUOP(2)

           DO PID^VADPT

 +5        SET PSUSSN=$TRANSLATE(VA("PID"),"^-","")

 +6       ;Patient counseling only exists for version 7.0

           SET PSUWPC=""

 +7        SET PSUDR=PSUOP(6)

 +8        SET PSURXP=PSUOP(3)

 +9       ;S PSUSIG=PSUOP(10)

 +10       DO GETDRUG^PSUOP3

 +11       QUIT 

CMOPARY   ;Loop through the "AR" cross reference and build CMOP array

 +1        SET X1=PSUSDT

           SET X2=-1

 +2        DO C^%DTC

           KILL %,%H,%T

 +3        SET PSUCDT=X

 +4        FOR 

               SET PSUCDT=$ORDER(^PSRX("AR",PSUCDT))

               IF 'PSUCDT

                   QUIT 

               Begin DoDot:1

 +5                SET PSUCRX=""

 +6                FOR 

                       SET PSUCRX=$ORDER(^PSRX("AR",PSUCDT,PSUCRX))

                       IF PSUCRX=""

                           QUIT 

                       Begin DoDot:2

 +7                        SET PSUCLN=""

 +8                        FOR 

                               SET PSUCLN=$ORDER(^PSRX("AR",PSUCDT,PSUCRX,PSUCLN))

                               IF PSUCLN=""

                                   QUIT 

                               Begin DoDot:3

 +9                                SET ^TMP($JOB,PSUCRX,PSUCLN)=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +10       QUIT