AQAQMCP ;IHS/ANMC/LJF - PRINT MISSING CREDENTIALS; [ 04/03/95 7:57 AM ]
;;2.2;STAFF CREDENTIALS;**4,7**;01 OCT 1992
;
;***> initialize variables
S AQAQDUZ=$P(^DIC(3,DUZ,0),U,2),AQAQSTOP=""
S AQAQSITE=$P(^DIC(4,DUZ(2),0),U)
S AQAQPAGE=0,AQAQLINE="",$P(AQAQLINE,"=",80)="" D HEAD
I '$D(^UTILITY("AQAQMC",$J)) W !!,"NO MISSING CREDENTIALS FOUND" G END
;
;***> loop thru ^utility then print data
S AQAQSR=0
F S AQAQSR=$O(^UTILITY("AQAQMC",$J,AQAQSR)) Q:AQAQSR="" Q:AQAQSTOP=U D
.S AQAQNM=0
.F S AQAQNM=$O(^UTILITY("AQAQMC",$J,AQAQSR,AQAQNM)) Q:AQAQNM="" Q:AQAQSTOP=U D
..S AQAQ=0
..F S AQAQ=$O(^UTILITY("AQAQMC",$J,AQAQSR,AQAQNM,AQAQ)) Q:AQAQ="" Q:AQAQSTOP=U D
...;
...;**> print name, category and last application date
...S AQAQST=^(AQAQ) W !!,$E(AQAQNM,1,30) ;name
...S Y=$P(AQAQST,U),C=$P(^DD(9002165,.02,0),U,2)
...I Y'="" D Y^DIQ W ?35,Y ;category
...S Y=$P(AQAQST,U,2) X ^DD("DD") W ?60,Y ;application date
...;**> loop thru missing credentials and print them
...S AQAQMS=$P(AQAQST,U,3) D PRINTMSG Q:AQAQSTOP=U
...I $Y>(IOSL-5) D NEWPG
;
END ;***> end of job
I IOST["C-" K DIR S DIR(0)="E",DIR("A")="Hit RETURN to continue" D ^DIR
W @IOF D ^%ZISC D KILL^AQAQUTIL Q
;
;
NEWPG ;***> SUBRTN for end of page control
I IOST'?1"C-".E D HEAD S AQAQSTOP="" Q
I AQAQPAGE>0 K DIR S DIR(0)="E" D ^DIR S AQAQSTOP=X
I AQAQSTOP'=U D HEAD
Q
;
;
HEAD ;***> SUBRTN to print heading
I (IOST["C-")!(AQAQPAGE>0) W @IOF
W !,AQAQLINE S AQAQPAGE=AQAQPAGE+1
W !?8,"*****Confidential Medical Staff Data Covered by Privacy Act*****"
W !,AQAQDUZ,?80-$L(AQAQSITE)/2,AQAQSITE
S AQAQTY="MISSING CREDENTIALS REPORT"
W ! D ^%T W ?80-$L(AQAQTY)/2,AQAQTY,?70,"Page: ",AQAQPAGE
S Y=DT X ^DD("DD") S Y="As of "_Y W !?80-$L(Y)/2,Y
W !,"Provider Name",?35,"Staff Category",?58,"Last Application Date"
W !,AQAQLINE
Q
;
;
PRINTMSG ;***> SUBRTN to print missing credential messages
F S AQAQMSG=$E(AQAQMS,1) Q:AQAQMSG="" Q:AQAQSTOP=U D
.W:$P($T(@AQAQMSG),";;",2)'="" !
.W ?10,$P($T(@AQAQMSG),";;",2)
.I AQAQMSG="N" W !?15,"# of Letters on file: ",$P(^AQAQC(AQAQ,0),U,17)
.S AQAQMS=$E(AQAQMS,2,99)
.I $Y>(IOSL-4) D NEWPG
Q
;
;
A ;;Professional Degree NOT on file
B ;;Professional Degree NOT verified
C ;;Internship Certificate NOT on file
D ;;Internship NOT verified
F ;;2nd Residency/Fellowship NOT verified
G ;;Residency Certificate NOT on file
H ;;Residency NOT verified
I ;;Bylaws Agreement NOT signed
J ;;Information Release NOT signed
K ;;Curriculum Vitae NOT on file
N ;;Number of Letters of Reference NOT acceptable
O ;;Health Status NOT on file
P ;;NPDB Inquiry NOT Made;;PATCH #4
Z ;;No Medical License Entered;;PATCH #7
AQAQMCP ;IHS/ANMC/LJF - PRINT MISSING CREDENTIALS; [ 04/03/95 7:57 AM ]
+1 ;;2.2;STAFF CREDENTIALS;**4,7**;01 OCT 1992
+2 ;
+3 ;***> initialize variables
+4 SET AQAQDUZ=$PIECE(^DIC(3,DUZ,0),U,2)
SET AQAQSTOP=""
+5 SET AQAQSITE=$PIECE(^DIC(4,DUZ(2),0),U)
+6 SET AQAQPAGE=0
SET AQAQLINE=""
SET $PIECE(AQAQLINE,"=",80)=""
DO HEAD
+7 IF '$DATA(^UTILITY("AQAQMC",$JOB))
WRITE !!,"NO MISSING CREDENTIALS FOUND"
GOTO END
+8 ;
+9 ;***> loop thru ^utility then print data
+10 SET AQAQSR=0
+11 FOR
SET AQAQSR=$ORDER(^UTILITY("AQAQMC",$JOB,AQAQSR))
IF AQAQSR=""
QUIT
IF AQAQSTOP=U
QUIT
Begin DoDot:1
+12 SET AQAQNM=0
+13 FOR
SET AQAQNM=$ORDER(^UTILITY("AQAQMC",$JOB,AQAQSR,AQAQNM))
IF AQAQNM=""
QUIT
IF AQAQSTOP=U
QUIT
Begin DoDot:2
+14 SET AQAQ=0
+15 FOR
SET AQAQ=$ORDER(^UTILITY("AQAQMC",$JOB,AQAQSR,AQAQNM,AQAQ))
IF AQAQ=""
QUIT
IF AQAQSTOP=U
QUIT
Begin DoDot:3
+16 ;
+17 ;**> print name, category and last application date
+18 ;name
SET AQAQST=^(AQAQ)
WRITE !!,$EXTRACT(AQAQNM,1,30)
+19 SET Y=$PIECE(AQAQST,U)
SET C=$PIECE(^DD(9002165,.02,0),U,2)
+20 ;category
IF Y'=""
DO Y^DIQ
WRITE ?35,Y
+21 ;application date
SET Y=$PIECE(AQAQST,U,2)
XECUTE ^DD("DD")
WRITE ?60,Y
+22 ;**> loop thru missing credentials and print them
+23 SET AQAQMS=$PIECE(AQAQST,U,3)
DO PRINTMSG
IF AQAQSTOP=U
QUIT
+24 IF $Y>(IOSL-5)
DO NEWPG
End DoDot:3
End DoDot:2
End DoDot:1
+25 ;
END ;***> end of job
+1 IF IOST["C-"
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Hit RETURN to continue"
DO ^DIR
+2 WRITE @IOF
DO ^%ZISC
DO KILL^AQAQUTIL
QUIT
+3 ;
+4 ;
NEWPG ;***> SUBRTN for end of page control
+1 IF IOST'?1"C-".E
DO HEAD
SET AQAQSTOP=""
QUIT
+2 IF AQAQPAGE>0
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET AQAQSTOP=X
+3 IF AQAQSTOP'=U
DO HEAD
+4 QUIT
+5 ;
+6 ;
HEAD ;***> SUBRTN to print heading
+1 IF (IOST["C-")!(AQAQPAGE>0)
WRITE @IOF
+2 WRITE !,AQAQLINE
SET AQAQPAGE=AQAQPAGE+1
+3 WRITE !?8,"*****Confidential Medical Staff Data Covered by Privacy Act*****"
+4 WRITE !,AQAQDUZ,?80-$LENGTH(AQAQSITE)/2,AQAQSITE
+5 SET AQAQTY="MISSING CREDENTIALS REPORT"
+6 WRITE !
DO ^%T
WRITE ?80-$LENGTH(AQAQTY)/2,AQAQTY,?70,"Page: ",AQAQPAGE
+7 SET Y=DT
XECUTE ^DD("DD")
SET Y="As of "_Y
WRITE !?80-$LENGTH(Y)/2,Y
+8 WRITE !,"Provider Name",?35,"Staff Category",?58,"Last Application Date"
+9 WRITE !,AQAQLINE
+10 QUIT
+11 ;
+12 ;
PRINTMSG ;***> SUBRTN to print missing credential messages
+1 FOR
SET AQAQMSG=$EXTRACT(AQAQMS,1)
IF AQAQMSG=""
QUIT
IF AQAQSTOP=U
QUIT
Begin DoDot:1
+2 IF $PIECE($TEXT(@AQAQMSG),";;",2)'=""
WRITE !
+3 WRITE ?10,$PIECE($TEXT(@AQAQMSG),";;",2)
+4 IF AQAQMSG="N"
WRITE !?15,"# of Letters on file: ",$PIECE(^AQAQC(AQAQ,0),U,17)
+5 SET AQAQMS=$EXTRACT(AQAQMS,2,99)
+6 IF $Y>(IOSL-4)
DO NEWPG
End DoDot:1
+7 QUIT
+8 ;
+9 ;
A ;;Professional Degree NOT on file
B ;;Professional Degree NOT verified
C ;;Internship Certificate NOT on file
D ;;Internship NOT verified
F ;;2nd Residency/Fellowship NOT verified
G ;;Residency Certificate NOT on file
H ;;Residency NOT verified
I ;;Bylaws Agreement NOT signed
J ;;Information Release NOT signed
K ;;Curriculum Vitae NOT on file
N ;;Number of Letters of Reference NOT acceptable
O ;;Health Status NOT on file
P ;;NPDB Inquiry NOT Made;;PATCH #4
Z ;;No Medical License Entered;;PATCH #7
