- 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
