AZP3UTL.m

AZP3UTL ;UTILITY PROGRAM [ 01/31/91  1:32 PM ]

 ;FCJ 09/10/90

VAR S FACPT=DUZ(2),(RXTOT,ND,PFAC)=0,(ANS,ODT,BDT,EDT)="",U="^"

 S Y=DT X ^DD("DD") S DATE=Y

 S:RX="Y" %ZIS("A")="Enter the device to print Pharmacy data: "

 S:RX="N" %ZIS("A")="Enter the device to print HCFA 1500 forms: "

 D ^%ZIS

A U IO(0) W @IOF,!

 R:RX="Y" "Do you want to print an individual Pharmacy claims? (Y or N) ",ANS:100

 R:RX="N" "Do you want to print an individual HCFA 1500? (Y or N) ",ANS:100

 I (ANS="^")!(ANS="") S RX="" G EXIT

 G:ANS="Y" A1 G:ANS="N" A2 G A

A1 R !!,"Enter the document # you wish to print.  ",BDOC I BDOC="?" D LIST G A1

 I (BDOC="^")!(BDOC="") S RX="" G EXIT 

 I '$D(^AZPPI(1,"B",BDOC)) W !,"INVAILID DOCUMENT NUMBER" G A1

 S EDOC=$E(BDOC,5,8),ETSTDOC=$E(BDOC,1,2)_EDOC Q

A2 R !,"Enter the beginning document number. ",BDOC I BDOC="?" D LIST G A2

 I (BDOC="^")!(BDOC="") S RX="" G EXIT

 I '$D(^AZPPI(1,"B",BDOC)) W !,"INVAILID DOCUMENT NUMBER" G A2

A3 R !,"Enter the ending document number. ",EDOC I EDOC="?" D LIST G A3

 I (EDOC="^")!(EDOC="") S RX="" G EXIT

 I '$D(^AZPPI(1,"B",EDOC)) W !,"INVAILID DOCUMENT NUMBER" G A3

 I $E(EDOC,3,4)'=$E(BDOC,3,4) W !,"YOU MUST PRINT BEGINNING AND ENDING DOCUMENTS FROM THE SAME FACILITY. " G A2

 S ETSTDOC=$E(EDOC,1,2)_$E(EDOC,5,8)

EXIT K DCL,DCL1,PAT Q

LIST R !!,"You may enter a document number to begin the list from",!,"or list will begin from first document.  ex. 90YH0001 : ",DCL  S:DCL="" DCL=0 Q:DCL="^"

 I DCL'=0 S DCL1=10000+$E(DCL,5,8)-1,DCL=$E(DCL,1,4)_$E(DCL1,2,5)

 F  S DCL=$O(^AZPPI(1,"B",DCL)) Q:DCL=""  D

 .S DCL1=0,PAT=0 F  S DCL1=$O(^AZPPI(1,"B",DCL,DCL1)) Q:DCL1=""  S PAT=$P(^AZPPI(1,DCL1,0),U,2),PAT=$P(^DPT(PAT,0),U) W !?5,DCL,"  ",PAT

 Q

KLL ;

 K ETSTDOC,BTSTDOC,ARID,AUTH,DATA3,DATA4,DATAF,DATAF1,DOB,EMG,FAC,INSP,L1,LAB,LABC,LEND,PHY,PHY,PT,RLS,SEX,SSN,SX,TB

KLL2 X ^%ZIS("C")

 K BDOC,EDOC,%H,%I,DATE,BDT,CTY,DATA2,DOCNO,EDT,FACPT,HRN,NM,ODT,PFAC,POP,ST,STR,ZIP

KLL3 K ID,%,X,Y,INS,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX,C,DISYS,D0,D1,D2,DFN,DI,DOC1,DQ,DRGUNT,L,ND3,NDC,PDRG,PHAR,CYR,ANS,ND,ND1,ND2,DOC,DA,DIE,DR,DIC,DIC(0),DIC("A")

 K UNTS,TOTCPT,%X,%Y,BELG,EELG,INSC,PINS,SINS,DATA,DATA1,PDOS,PCPT,DOS,TOS,POS,TOT,RX,RXDSP,RXTOT,RXDT,PRX,PRX1,RXDATA,RXCST,CST,RXQTY,CRGUNT,DRGCST,ICD,PICD

 Q

AZP3UTL   ;UTILITY PROGRAM [ 01/31/91  1:32 PM ]

 +1       ;FCJ 09/10/90

VAR        SET FACPT=DUZ(2)

           SET (RXTOT,ND,PFAC)=0

           SET (ANS,ODT,BDT,EDT)=""

           SET U="^"

 +1        SET Y=DT

           XECUTE ^DD("DD")

           SET DATE=Y

 +2        IF RX="Y"

               SET %ZIS("A")="Enter the device to print Pharmacy data: "

 +3        IF RX="N"

               SET %ZIS("A")="Enter the device to print HCFA 1500 forms: "

 +4        DO ^%ZIS

A          USE IO(0)

           WRITE @IOF,!

 +1        IF RX="Y"

               READ "Do you want to print an individual Pharmacy claims? (Y or N) ",ANS:100

 +2        IF RX="N"

               READ "Do you want to print an individual HCFA 1500? (Y or N) ",ANS:100

 +3        IF (ANS="^")!(ANS="")

               SET RX=""

               GOTO EXIT

 +4        IF ANS="Y"

               GOTO A1

           IF ANS="N"

               GOTO A2

           GOTO A

A1         READ !!,"Enter the document # you wish to print.  ",BDOC

           IF BDOC="?"

               DO LIST

               GOTO A1

 +1        IF (BDOC="^")!(BDOC="")

               SET RX=""

               GOTO EXIT

 +2        IF '$DATA(^AZPPI(1,"B",BDOC))

               WRITE !,"INVAILID DOCUMENT NUMBER"

               GOTO A1

 +3        SET EDOC=$EXTRACT(BDOC,5,8)

           SET ETSTDOC=$EXTRACT(BDOC,1,2)_EDOC

           QUIT 

A2         READ !,"Enter the beginning document number. ",BDOC

           IF BDOC="?"

               DO LIST

               GOTO A2

 +1        IF (BDOC="^")!(BDOC="")

               SET RX=""

               GOTO EXIT

 +2        IF '$DATA(^AZPPI(1,"B",BDOC))

               WRITE !,"INVAILID DOCUMENT NUMBER"

               GOTO A2

A3         READ !,"Enter the ending document number. ",EDOC

           IF EDOC="?"

               DO LIST

               GOTO A3

 +1        IF (EDOC="^")!(EDOC="")

               SET RX=""

               GOTO EXIT

 +2        IF '$DATA(^AZPPI(1,"B",EDOC))

               WRITE !,"INVAILID DOCUMENT NUMBER"

               GOTO A3

 +3        IF $EXTRACT(EDOC,3,4)'=$EXTRACT(BDOC,3,4)

               WRITE !,"YOU MUST PRINT BEGINNING AND ENDING DOCUMENTS FROM THE SAME FACILITY. "

               GOTO A2

 +4        SET ETSTDOC=$EXTRACT(EDOC,1,2)_$EXTRACT(EDOC,5,8)

EXIT       KILL DCL,DCL1,PAT

           QUIT 

LIST       READ !!,"You may enter a document number to begin the list from",!,"or list will begin from first document.  ex. 90YH0001 : ",DCL

           IF DCL=""

               SET DCL=0

           IF DCL="^"

               QUIT 

 +1        IF DCL'=0

               SET DCL1=10000+$EXTRACT(DCL,5,8)-1

               SET DCL=$EXTRACT(DCL,1,4)_$EXTRACT(DCL1,2,5)

 +2        FOR 

               SET DCL=$ORDER(^AZPPI(1,"B",DCL))

               IF DCL=""

                   QUIT 

               Begin DoDot:1

 +3                SET DCL1=0

                   SET PAT=0

                   FOR 

                       SET DCL1=$ORDER(^AZPPI(1,"B",DCL,DCL1))

                       IF DCL1=""

                           QUIT 

                       SET PAT=$PIECE(^AZPPI(1,DCL1,0),U,2)

                       SET PAT=$PIECE(^DPT(PAT,0),U)

                       WRITE !?5,DCL,"  ",PAT

               End DoDot:1

 +4        QUIT 

KLL       ;

 +1        KILL ETSTDOC,BTSTDOC,ARID,AUTH,DATA3,DATA4,DATAF,DATAF1,DOB,EMG,FAC,INSP,L1,LAB,LABC,LEND,PHY,PHY,PT,RLS,SEX,SSN,SX,TB

KLL2       XECUTE ^%ZIS("C")

 +1        KILL BDOC,EDOC,%H,%I,DATE,BDT,CTY,DATA2,DOCNO,EDT,FACPT,HRN,NM,ODT,PFAC,POP,ST,STR,ZIP

KLL3       KILL ID,%,X,Y,INS,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX,C,DISYS,D0,D1,D2,DFN,DI,DOC1,DQ,DRGUNT,L,ND3,NDC,PDRG,PHAR,CYR,ANS,ND,ND1,ND2,DOC,DA,DIE,DR,DIC,DIC(0),DIC("A")

 +1        KILL UNTS,TOTCPT,%X,%Y,BELG,EELG,INSC,PINS,SINS,DATA,DATA1,PDOS,PCPT,DOS,TOS,POS,TOT,RX,RXDSP,RXTOT,RXDT,PRX,PRX1,RXDATA,RXCST,CST,RXQTY,CRGUNT,DRGCST,ICD,PICD

 +2        QUIT