AQAQPR11.m

AQAQPR11 ;IHS/ANMC/LJF - ADMISSION BY PROVIDER; [ 05/27/92  11:21 AM ]

 ;;2.2;STAFF CREDENTIALS;;01 OCT 1992

 ;

 ;***> initialize variables

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

 K ^UTILITY("AQAQPR1",$J)

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

 ;

 ;

ADM ;***> find admissions for specified date range

 S AQAQDT=$O(^DPT("AA",AQAQDT)) G NEXT:AQAQDT="",NEXT:AQAQDT>AQAQEND

 S DFN=0

ADM1 S DFN=$O(^DPT("AA",AQAQDT,DFN)) G ADM:DFN="" S AQAQA=0

ADM2 S AQAQA=$O(^DPT("AA",AQAQDT,DFN,AQAQA)) G ADM1:AQAQA=""

 ;

 S AQAQNM=$P(^DPT(DFN,0),U)  ;patient name

 G ADM2:'$D(^DPT(DFN,"DA",AQAQA,0))#2 S AQAQS=^(0)

 S AQAQW=$P(AQAQS,U,4),AQAQICU=$S($P(^DIC(42,AQAQW,"IHS"),U)="Y":1,1:0)

 S AQAQW=$P(^DIC(42,AQAQW,0),U)  ;ward

 S AQAQDX=$P(AQAQS,U,6)  ;admit dx

 G ADM2:'$D(^DPT(DFN,"DA",AQAQA,"T",1,0))

 S AQAQSV=$P(^(0),U,2),AQAQPRV=$P(^(0),U,3)

 S AQAQSRV=$S(AQAQSV="":"NO SERVICE",1:$P(^DIC(45.7,AQAQSV,0),U))  ;srv

 I AQAQTYP=1 G:AQAQPRV'=+AQAQPROV ADM2   ;wrong provider

 I AQAQTYP=2 G:$P($G(^DIC(6,+AQAQPRV,0)),U,4)'=+AQAQPROV ADM2  ;class

 I AQAQPRV="" S AQAQPRV="UNKNOWN"

 E  S AQAQPRV=$P(^DIC(16,AQAQPRV,0),U)  ;admit provider

 S AQAQSTR=AQAQNM_U_AQAQW_U_AQAQSRV_U_AQAQDX_U_AQAQICU

 ;

 ;***> sorted by date then alpha

 S ^UTILITY("AQAQPR1",$J,AQAQPRV,AQAQDT,DFN)=AQAQSTR G ADM2

 ;

 ;***> go to print rtn

NEXT G ^AQAQPR12

AQAQPR11  ;IHS/ANMC/LJF - ADMISSION BY PROVIDER; [ 05/27/92  11:21 AM ]

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

 +2       ;

 +3       ;***> initialize variables

 +4       ;allow break

           SET X="ERR^AQAQPR1"

           SET @^%ZOSF("TRAP")

           XECUTE ^%ZOSF("BRK")

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

 +6        SET AQAQDT=AQAQBDT-.0001

           SET AQAQEND=AQAQEDT+.2400

 +7       ;

 +8       ;

ADM       ;***> find admissions for specified date range

 +1        SET AQAQDT=$ORDER(^DPT("AA",AQAQDT))

           IF AQAQDT=""

               GOTO NEXT

           IF AQAQDT>AQAQEND

               GOTO NEXT

 +2        SET DFN=0

ADM1       SET DFN=$ORDER(^DPT("AA",AQAQDT,DFN))

           IF DFN=""

               GOTO ADM

           SET AQAQA=0

ADM2       SET AQAQA=$ORDER(^DPT("AA",AQAQDT,DFN,AQAQA))

           IF AQAQA=""

               GOTO ADM1

 +1       ;

 +2       ;patient name

           SET AQAQNM=$PIECE(^DPT(DFN,0),U)

 +3        IF '$DATA(^DPT(DFN,"DA",AQAQA,0))#2

               GOTO ADM2

           SET AQAQS=^(0)

 +4        SET AQAQW=$PIECE(AQAQS,U,4)

           SET AQAQICU=$SELECT($PIECE(^DIC(42,AQAQW,"IHS"),U)="Y":1,1:0)

 +5       ;ward

           SET AQAQW=$PIECE(^DIC(42,AQAQW,0),U)

 +6       ;admit dx

           SET AQAQDX=$PIECE(AQAQS,U,6)

 +7        IF '$DATA(^DPT(DFN,"DA",AQAQA,"T",1,0))

               GOTO ADM2

 +8        SET AQAQSV=$PIECE(^(0),U,2)

           SET AQAQPRV=$PIECE(^(0),U,3)

 +9       ;srv

           SET AQAQSRV=$SELECT(AQAQSV="":"NO SERVICE",1:$PIECE(^DIC(45.7,AQAQSV,0),U))

 +10      ;wrong provider

           IF AQAQTYP=1

               IF AQAQPRV'=+AQAQPROV

                   GOTO ADM2

 +11      ;class

           IF AQAQTYP=2

               IF $PIECE($GET(^DIC(6,+AQAQPRV,0)),U,4)'=+AQAQPROV

                   GOTO ADM2

 +12       IF AQAQPRV=""

               SET AQAQPRV="UNKNOWN"

 +13      ;admit provider

          IF '$TEST

               SET AQAQPRV=$PIECE(^DIC(16,AQAQPRV,0),U)

 +14       SET AQAQSTR=AQAQNM_U_AQAQW_U_AQAQSRV_U_AQAQDX_U_AQAQICU

 +15      ;

 +16      ;***> sorted by date then alpha

 +17       SET ^UTILITY("AQAQPR1",$JOB,AQAQPRV,AQAQDT,DFN)=AQAQSTR

           GOTO ADM2

 +18      ;

 +19      ;***> go to print rtn

NEXT       GOTO ^AQAQPR12