AQAQPR21.m

AQAQPR21 ;IHS/ANMC/LJF - PROCEDURES BY PROVIDER; [ 05/27/92  11:28 AM ]

 ;;2.2;STAFF CREDENTIALS;;01 OCT 1992

 ;

 ;>>> initialize variables  <<<

 S X="ERR^AQAQPR2",@^%ZOSF("TRAP") X ^%ZOSF("BRK")  ;allow break

 K ^UTILITY("AQAQPR2",$J)

 S AQAQDT=AQAQBDT-.0001,AQAQEND=AQAQEDT+.2400

 ;

 ;>>> loop thru visit file by date and screen visit

 F  S AQAQDT=$O(^AUPNVSIT("B",AQAQDT)) Q:AQAQDT=""  Q:AQAQDT>AQAQEND  D

 .S AQAQVDFN=0

 .F  S AQAQVDFN=$O(^AUPNVSIT("B",AQAQDT,AQAQVDFN)) Q:AQAQVDFN=""  D

 ..Q:'$D(^AUPNVSIT(AQAQVDFN,0))  S AQAQV=^(0)

 ..Q:$P(AQAQV,U,11)=1            ;deleted visit

 ..Q:$P(AQAQV,U,9)<3             ;must have prov,pov, & proc entries

 ..Q:"AHIS"'[$P(AQAQV,U,7)       ;service category

 ..Q:$P(AQAQV,U,6)'=DUZ(2)       ;location of encounter

 ..D FINDPROC                    ;get procedures for this visit

 ..Q                             ;get next visit

 ;

NEXT ;>>> go to print rtn <<<

 G ^AQAQPR22

 ;

 ;>>> end of main rtn <<<

 ;

FINDPROC ;***> SUBRTN to get procedures for visits that passed screens

 S (AQAQPDFN,AQAQPRV)=0

 F  S AQAQPDFN=$O(^AUPNVPRC("AD",AQAQVDFN,AQAQPDFN)) Q:AQAQPDFN=""  D

 .Q:'$D(^AUPNVPRC(AQAQPDFN,0))  S AQAQP=^(0)

 .S AQAQICD=$P(^ICD0($P(AQAQP,U),0),U)     ;icd code number

 .S AQAQICDN=$P(^ICD0($P(AQAQP,U),0),U,4)  ;icd narrative

 .I $P(AQAQV,U,7)="H" S AQAQPRV=$P(AQAQP,U,11)   ;oper prov for hosp

 .E  D FINDPROV                   ;get primary provider for visit

 .Q:AQAQPRV=0  Q:AQAQPRV=""       ;bad visit-no primary provider

 .I AQAQTYP=1,AQAQSRT'="" Q:+AQAQSRT'=AQAQPRV  ;not provider asked for

 .S AQAQCLS=$P(^DIC(6,AQAQPRV,0),U,4)  ;provider class

 .I AQAQTYP=2 Q:+AQAQSRT'=AQAQCLS  ;not prov class asked for

 .S AQAQCAT=$P($G(^AQAQC(AQAQPRV,0)),U,2)  ;staff category

 .I AQAQTYP=3 Q:AQAQSRT'=AQAQCAT  ;not category asked for

 .S AQAQX=$P(^DIC(6,AQAQPRV,0),U,4)

 .S:AQAQX'="" AQAQX=$P(^DIC(7,AQAQX,0),U)

 .S AQAQPRV=$P(^DIC(16,AQAQPRV,0),U)_" ("_AQAQX_")"

 .;

 .S AQAQSTR=AQAQPDFN_U_AQAQICDN            ;set data in ^utility

 .S ^UTILITY("AQAQPR2",$J,AQAQPRV,+AQAQICD,AQAQDT,AQAQVDFN)=AQAQSTR Q

 Q                                         ;return to main rtn loop

 ;

 ;

FINDPROV ;***> SUBRTN to find primary provider for ambulatory visits

 S AQAQRDFN=0

 F  S AQAQRDFN=$O(^AUPNVPRV("AD",AQAQVDFN,AQAQRDFN)) Q:AQAQRDFN=""  D

 .Q:'$D(^AUPNVPRV(AQAQRDFN,0))  S AQAQR=^(0)

 .Q:$P(AQAQR,U,4)'="P"          ;find another if not primary provider

 .S AQAQPRV=$P(AQAQR,U)         ;get provider pointer

 Q                              ;return to procedure subrtn

 ;

 ;

HOSPERR ;***> SUBRTN to find all prov for inpt proc without oper provider

 S AQAQRDFN=0

 F  S AQAQRDFN=$O(^AUPNVPRV("AD",AQAQVDFN,AQAQRDFN)) Q:AQAQRDFN=""  D

 .Q:'$D(^AUPNVPRV(AQAQRDFN,0))  S AQAQR=^(0)

 .S AQAQSTR=AQAQVDFN_U_AQAQICDN_U_AQAQPDFN_U_AQAQDT

 .S ^UTILITY("AQAQPR2",$J,"zz",AQAQICD,AQAQVDFN,AQAQRDFN)=AQAQSTR Q

 Q                    ;return to procedure subrtn

AQAQPR21  ;IHS/ANMC/LJF - PROCEDURES BY PROVIDER; [ 05/27/92  11:28 AM ]

 +1       ;;2.2;STAFF CREDENTIALS;;01 OCT 1992

 +2       ;

 +3       ;>>> initialize variables  <<<

 +4       ;allow break

           SET X="ERR^AQAQPR2"

           SET @^%ZOSF("TRAP")

           XECUTE ^%ZOSF("BRK")

 +5        KILL ^UTILITY("AQAQPR2",$JOB)

 +6        SET AQAQDT=AQAQBDT-.0001

           SET AQAQEND=AQAQEDT+.2400

 +7       ;

 +8       ;>>> loop thru visit file by date and screen visit

 +9        FOR 

               SET AQAQDT=$ORDER(^AUPNVSIT("B",AQAQDT))

               IF AQAQDT=""

                   QUIT 

               IF AQAQDT>AQAQEND

                   QUIT 

               Begin DoDot:1

 +10               SET AQAQVDFN=0

 +11               FOR 

                       SET AQAQVDFN=$ORDER(^AUPNVSIT("B",AQAQDT,AQAQVDFN))

                       IF AQAQVDFN=""

                           QUIT 

                       Begin DoDot:2

 +12                       IF '$DATA(^AUPNVSIT(AQAQVDFN,0))

                               QUIT 

                           SET AQAQV=^(0)

 +13      ;deleted visit

                           IF $PIECE(AQAQV,U,11)=1

                               QUIT 

 +14      ;must have prov,pov, & proc entries

                           IF $PIECE(AQAQV,U,9)<3

                               QUIT 

 +15      ;service category

                           IF "AHIS"'[$PIECE(AQAQV,U,7)

                               QUIT 

 +16      ;location of encounter

                           IF $PIECE(AQAQV,U,6)'=DUZ(2)

                               QUIT 

 +17      ;get procedures for this visit

                           DO FINDPROC

 +18      ;get next visit

                           QUIT 

                       End DoDot:2

               End DoDot:1

 +19      ;

NEXT      ;>>> go to print rtn <<<

 +1        GOTO ^AQAQPR22

 +2       ;

 +3       ;>>> end of main rtn <<<

 +4       ;

FINDPROC  ;***> SUBRTN to get procedures for visits that passed screens

 +1        SET (AQAQPDFN,AQAQPRV)=0

 +2        FOR 

               SET AQAQPDFN=$ORDER(^AUPNVPRC("AD",AQAQVDFN,AQAQPDFN))

               IF AQAQPDFN=""

                   QUIT 

               Begin DoDot:1

 +3                IF '$DATA(^AUPNVPRC(AQAQPDFN,0))

                       QUIT 

                   SET AQAQP=^(0)

 +4       ;icd code number

                   SET AQAQICD=$PIECE(^ICD0($PIECE(AQAQP,U),0),U)

 +5       ;icd narrative

                   SET AQAQICDN=$PIECE(^ICD0($PIECE(AQAQP,U),0),U,4)

 +6       ;oper prov for hosp

                   IF $PIECE(AQAQV,U,7)="H"

                       SET AQAQPRV=$PIECE(AQAQP,U,11)

 +7       ;get primary provider for visit

                  IF '$TEST

                       DO FINDPROV

 +8       ;bad visit-no primary provider

                   IF AQAQPRV=0

                       QUIT 

                   IF AQAQPRV=""

                       QUIT 

 +9       ;not provider asked for

                   IF AQAQTYP=1

                       IF AQAQSRT'=""

                           IF +AQAQSRT'=AQAQPRV

                               QUIT 

 +10      ;provider class

                   SET AQAQCLS=$PIECE(^DIC(6,AQAQPRV,0),U,4)

 +11      ;not prov class asked for

                   IF AQAQTYP=2

                       IF +AQAQSRT'=AQAQCLS

                           QUIT 

 +12      ;staff category

                   SET AQAQCAT=$PIECE($GET(^AQAQC(AQAQPRV,0)),U,2)

 +13      ;not category asked for

                   IF AQAQTYP=3

                       IF AQAQSRT'=AQAQCAT

                           QUIT 

 +14               SET AQAQX=$PIECE(^DIC(6,AQAQPRV,0),U,4)

 +15               IF AQAQX'=""

                       SET AQAQX=$PIECE(^DIC(7,AQAQX,0),U)

 +16               SET AQAQPRV=$PIECE(^DIC(16,AQAQPRV,0),U)_" ("_AQAQX_")"

 +17      ;

 +18      ;set data in ^utility

                   SET AQAQSTR=AQAQPDFN_U_AQAQICDN

 +19               SET ^UTILITY("AQAQPR2",$JOB,AQAQPRV,+AQAQICD,AQAQDT,AQAQVDFN)=AQAQSTR

                   QUIT 

               End DoDot:1

 +20      ;return to main rtn loop

           QUIT 

 +21      ;

 +22      ;

FINDPROV  ;***> SUBRTN to find primary provider for ambulatory visits

 +1        SET AQAQRDFN=0

 +2        FOR 

               SET AQAQRDFN=$ORDER(^AUPNVPRV("AD",AQAQVDFN,AQAQRDFN))

               IF AQAQRDFN=""

                   QUIT 

               Begin DoDot:1

 +3                IF '$DATA(^AUPNVPRV(AQAQRDFN,0))

                       QUIT 

                   SET AQAQR=^(0)

 +4       ;find another if not primary provider

                   IF $PIECE(AQAQR,U,4)'="P"

                       QUIT 

 +5       ;get provider pointer

                   SET AQAQPRV=$PIECE(AQAQR,U)

               End DoDot:1

 +6       ;return to procedure subrtn

           QUIT 

 +7       ;

 +8       ;

HOSPERR   ;***> SUBRTN to find all prov for inpt proc without oper provider

 +1        SET AQAQRDFN=0

 +2        FOR 

               SET AQAQRDFN=$ORDER(^AUPNVPRV("AD",AQAQVDFN,AQAQRDFN))

               IF AQAQRDFN=""

                   QUIT 

               Begin DoDot:1

 +3                IF '$DATA(^AUPNVPRV(AQAQRDFN,0))

                       QUIT 

                   SET AQAQR=^(0)

 +4                SET AQAQSTR=AQAQVDFN_U_AQAQICDN_U_AQAQPDFN_U_AQAQDT

 +5                SET ^UTILITY("AQAQPR2",$JOB,"zz",AQAQICD,AQAQVDFN,AQAQRDFN)=AQAQSTR

                   QUIT 

               End DoDot:1

 +6       ;return to procedure subrtn

           QUIT