AQAQMCC.m

AQAQMCC ;IHS/ANMC/LJF - CALCULATE MISSING CREDENTIALS; [ 04/03/95  8:15 AM ]

 ;;2.2;STAFF CREDENTIALS;**4,7**;01 OCT 1992

 ;

 ;

 ;>>>> BEGIN OF MAIN RTOUTINE

 K ^UTILITY("AQAQMC",$J)

 ;

 ;***> loop thru credentials file

 S AQAQ=0

 F  S AQAQ=$O(^AQAQC(AQAQ)) Q:AQAQ'=+AQAQ  D

 .;

 .;**> screen by sort criteria

 .I $D(^DIC(6,AQAQ,"I")),^("I")'="" Q:$P(^("I"),U)'>DT  ;inactive

 .S AQAQS0=$G(^AQAQC(AQAQ,0)),AQAQMS=""

 .S AQAQNM=$P(AQAQS0,U),AQAQCAT=$P(AQAQS0,U,2)

 .I AQAQTYP=2,AQAQSRT'="ALL" Q:$P(^DIC(6,AQAQNM,0),U,4)'=+AQAQSRT

 .I AQAQTYP=3,AQAQSRT'="ALL" Q:AQAQCAT'=AQAQSRT

 .S AQAQSR=$S(AQAQTYP=1:1,AQAQTYP=3:AQAQCAT,1:$P(^DIC(6,AQAQNM,0),U,4))

 .;

 .;**> check for missing credentials

 .F AQAQP=5,7,11 D EDUCACHK

 .F AQAQP=13,14,15,16,18,19 D OTHRCHK

 .S AQAQP=$P(^AQAQC(AQAQ,2),U,6)

 .I AQAQP=""!(AQAQP="N") S AQAQMS=AQAQMS_"P" ;IHS/OKCRDC/BJH 10/5/93 PATCH 4

 .I '$D(^AQAQML("C",AQAQ)) S AQAQMS=AQAQMS_"Z" ;PATCH #7

 .;

 .;**> set node for provider if any credentials are missing

 .Q:AQAQMS=""  ;all okay

 .S AQAQNM=$P(^DIC(16,AQAQNM,0),U)

 .S AQAQRE=$P(AQAQS0,U,3) D LASTREAP

 .S ^UTILITY("AQAQMC",$J,AQAQSR,AQAQNM,AQAQ)=AQAQCAT_U_AQAQRE_U_AQAQMS

 ;

 ;***> go to print routine

 G ^AQAQMCP

 ;

 ;>>>> END OF MAIN ROUTINE <<<<

 ;

 ;

EDUCACHK ;***> SUBRTN to check for missing education credentials

 Q:$P(AQAQS0,U,AQAQP)="NA"

 I $P(AQAQS0,U,AQAQP)'="Y" S AQAQMS=AQAQMS_$P($T(CODE),";;",AQAQP-3) Q

 I $P(AQAQS0,U,AQAQP+1)'="Y" S AQAQMS=AQAQMS_$P($T(CODE),";;",AQAQP-2)

 Q

 ;

OTHRCHK ;***> SUBRTN to check for other missing credentials

 Q:$P(AQAQS0,U,AQAQP)="Y"  Q:$P(AQAQS0,U,AQAQP)="NA"

 S AQAQMS=AQAQMS_$P($T(CODE),";;",AQAQP-3) Q

 ;

LASTREAP ;***> SUBRTN to find last reappointment application date

 S AQAQX=0

 F  S AQAQX=$O(^AQAQC(AQAQ,"R","B",AQAQX)) Q:AQAQX=""  D

 .I '$O(^AQAQC(AQAQ,"R","B",AQAQX)) S AQAQRE=AQAQX

 Q

 ;

CODE ;;A;;B;;C;;D;;E;;F;;G;;H;;I;;J;;K;;L;;M;;N;;O

AQAQMCC   ;IHS/ANMC/LJF - CALCULATE MISSING CREDENTIALS; [ 04/03/95  8:15 AM ]

 +1       ;;2.2;STAFF CREDENTIALS;**4,7**;01 OCT 1992

 +2       ;

 +3       ;

 +4       ;>>>> BEGIN OF MAIN RTOUTINE

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

 +6       ;

 +7       ;***> loop thru credentials file

 +8        SET AQAQ=0

 +9        FOR 

               SET AQAQ=$ORDER(^AQAQC(AQAQ))

               IF AQAQ'=+AQAQ

                   QUIT 

               Begin DoDot:1

 +10      ;

 +11      ;**> screen by sort criteria

 +12      ;inactive

                   IF $DATA(^DIC(6,AQAQ,"I"))

                       IF ^("I")'=""

                           IF $PIECE(^("I"),U)'>DT

                               QUIT 

 +13               SET AQAQS0=$GET(^AQAQC(AQAQ,0))

                   SET AQAQMS=""

 +14               SET AQAQNM=$PIECE(AQAQS0,U)

                   SET AQAQCAT=$PIECE(AQAQS0,U,2)

 +15               IF AQAQTYP=2

                       IF AQAQSRT'="ALL"

                           IF $PIECE(^DIC(6,AQAQNM,0),U,4)'=+AQAQSRT

                               QUIT 

 +16               IF AQAQTYP=3

                       IF AQAQSRT'="ALL"

                           IF AQAQCAT'=AQAQSRT

                               QUIT 

 +17               SET AQAQSR=$SELECT(AQAQTYP=1:1,AQAQTYP=3:AQAQCAT,1:$PIECE(^DIC(6,AQAQNM,0),U,4))

 +18      ;

 +19      ;**> check for missing credentials

 +20               FOR AQAQP=5,7,11

                       DO EDUCACHK

 +21               FOR AQAQP=13,14,15,16,18,19

                       DO OTHRCHK

 +22               SET AQAQP=$PIECE(^AQAQC(AQAQ,2),U,6)

 +23      ;IHS/OKCRDC/BJH 10/5/93 PATCH 4

                   IF AQAQP=""!(AQAQP="N")

                       SET AQAQMS=AQAQMS_"P"

 +24      ;PATCH #7

                   IF '$DATA(^AQAQML("C",AQAQ))

                       SET AQAQMS=AQAQMS_"Z"

 +25      ;

 +26      ;**> set node for provider if any credentials are missing

 +27      ;all okay

                   IF AQAQMS=""

                       QUIT 

 +28               SET AQAQNM=$PIECE(^DIC(16,AQAQNM,0),U)

 +29               SET AQAQRE=$PIECE(AQAQS0,U,3)

                   DO LASTREAP

 +30               SET ^UTILITY("AQAQMC",$JOB,AQAQSR,AQAQNM,AQAQ)=AQAQCAT_U_AQAQRE_U_AQAQMS

               End DoDot:1

 +31      ;

 +32      ;***> go to print routine

 +33       GOTO ^AQAQMCP

 +34      ;

 +35      ;>>>> END OF MAIN ROUTINE <<<<

 +36      ;

 +37      ;

EDUCACHK  ;***> SUBRTN to check for missing education credentials

 +1        IF $PIECE(AQAQS0,U,AQAQP)="NA"

               QUIT 

 +2        IF $PIECE(AQAQS0,U,AQAQP)'="Y"

               SET AQAQMS=AQAQMS_$PIECE($TEXT(CODE),";;",AQAQP-3)

               QUIT 

 +3        IF $PIECE(AQAQS0,U,AQAQP+1)'="Y"

               SET AQAQMS=AQAQMS_$PIECE($TEXT(CODE),";;",AQAQP-2)

 +4        QUIT 

 +5       ;

OTHRCHK   ;***> SUBRTN to check for other missing credentials

 +1        IF $PIECE(AQAQS0,U,AQAQP)="Y"

               QUIT 

           IF $PIECE(AQAQS0,U,AQAQP)="NA"

               QUIT 

 +2        SET AQAQMS=AQAQMS_$PIECE($TEXT(CODE),";;",AQAQP-3)

           QUIT 

 +3       ;

LASTREAP  ;***> SUBRTN to find last reappointment application date

 +1        SET AQAQX=0

 +2        FOR 

               SET AQAQX=$ORDER(^AQAQC(AQAQ,"R","B",AQAQX))

               IF AQAQX=""

                   QUIT 

               Begin DoDot:1

 +3                IF '$ORDER(^AQAQC(AQAQ,"R","B",AQAQX))

                       SET AQAQRE=AQAQX

               End DoDot:1

 +4        QUIT 

 +5       ;

CODE      ;;A;;B;;C;;D;;E;;F;;G;;H;;I;;J;;K;;L;;M;;N;;O