- AQAQRE1 ;IHS/ASU/RPL 4/17/89 ;Staff Credentials Recredentialing Due Report-Part 2 ; 11/7/89 10:07 AM [ 07/26/1999 10:21 AM ]
- ;;2.2;STAFF CREDENTIALS;**8**;01 OCT 1992
- ;;AQAQ*2*8;Y2K FIX;CS;2990708
- ;
- START S AQAQ80D="--------------------------------------------------------------------------------"
- S Y=DT X ^DD("DD") S AQAQDTP=Y
- S AQAQSTRT=""
- S AQAQPG=0 D HEAD
- S AQAQRCDU="" F I=0:0 S AQAQRCDU=$O(^UTILITY($J,AQAQRCDU)) Q:AQAQRCDU=""!($D(AQAQQUIT)) D P1
- G QUIT
- P1 S Y=AQAQRCDU X ^DD("DD") S AQAQRCDY=Y I AQAQRCDY=0 S AQAQRCDY="Never Credentialed"
- S AQAQDFN="" F J=0:0 S AQAQDFN=$O(^UTILITY($J,AQAQRCDU,AQAQDFN)) Q:AQAQDFN=""!($D(AQAQQUIT)) D P15
- Q
- P15 D:$Y>(IOSL-12) HEAD Q:$D(AQAQQUIT)
- S AQAQ=^UTILITY($J,AQAQRCDU,AQAQDFN)
- S AQAQNM=$P(AQAQ,"^"),AQAQSC=$P(AQAQ,"^",2),AQAQMLE=$P(AQAQ,"^",3),AQAQCME=$P(AQAQ,"^",4),AQAQHSV=$P(AQAQ,"^",5),AQAQCAD=$P(AQAQ,"^",6)
- S Y=AQAQMLE D DTCV S AQAQMLEY=Y
- S X1=AQAQMLE,X2=365+1 D C^%DTC S AQAQMLED=X,AQAQMLEO=$S(DT<X:"",1:"*******")
- S Y=AQAQMLED D DTCV S AQAQMLED=Y
- S Y=AQAQCME D DTCV S AQAQCMEY=Y
- S AQAQ1CAD=0 I 'AQAQCME S AQAQ1CAD=$O(^AQAQ(AQAQDFN,9,0)) S:AQAQ1CAD="" AQAQ1CAD=0
- I AQAQ1CAD S AQAQ1CAD=$P(^AQAQ(AQAQDFN,9,AQAQ1CAD,0),"^")
- S X1=$S(AQAQCME>0:AQAQCME,1:AQAQ1CAD),X2=365+1 D C^%DTC S AQAQCMED=X,AQAQCMEO=$S(X=0:"",DT<X:"",1:"*******")
- S Y=AQAQCMED D DTCV S AQAQCMED=Y
- S Y=AQAQHSV D DTCV S AQAQHSVY=Y
- S X1=AQAQHSV,X2=(365*2)+1 D C^%DTC S AQAQHSVD=X,AQAQHSVO=$S(DT<X:"",1:"*******")
- S Y=AQAQHSVD D DTCV S AQAQHSVD=Y
- S Y=AQAQCAD X ^DD("DD") S AQAQCADY=Y I AQAQCADY=0 S AQAQCADY="Pending Approval"
- W $E(AQAQNM,1,26),?28,$E(AQAQSC,1,20),?50,AQAQRCDY
- W !!,?48,"Current",?60,"Due",?70,"Overdue",!,?48,"--------",?60,"--------",?71,"-------"
- W !,?5,"Medical License Expires",?48,AQAQMLEY,?60,AQAQMLED,?71,AQAQMLEO,!
- W ?5,"CME Summary Last Updated",?48,AQAQCMEY,?60,AQAQCMED,?71,AQAQCMEO,!
- W ?5,"Last Health Status Verification",?48,AQAQHSVY,?60,AQAQHSVD,?71,AQAQHSVO,!
- W !,?5,"Board Certification:" I '$D(^AQAQ(AQAQDFN,1)) W " No Board Certification on file." G P2
- W ?33,"Certification",?50,"Verification",!,?5,"--------------------------",?33,"-------------",?50,"------------"
- S AQAQBC=0 F L=0:0 S AQAQBC=$O(^AQAQ(AQAQDFN,1,AQAQBC)) Q:AQAQBC="" D P3
- P2 W !!,?5,"Credentials Last Approved: ",AQAQCADY,!!!
- Q
- P3 S AQAQBRD=^AQAQ(AQAQDFN,1,AQAQBC,0) Q:AQAQBRD=""
- S Y=$P(AQAQBRD,"^") X ^DD("DD") S AQAQBRDY=Y I AQAQBRDY=0 S AQAQBRDY=""
- P31 S Y=$P(AQAQBRD,"^",3) X ^DD("DD") S AQAQBRDD=Y I AQAQBRDD=0 S AQAQBRDD=""
- S AQAQBRD=$P(AQAQBRD,"^",2) Q:AQAQBRD="" S AQAQBRD=$P(^AQAQBD(AQAQBRD,0),"^")
- W !,?5,$E(AQAQBRD,1,20),?33,AQAQBRDY,?48,AQAQBRDD
- Q
- HEAD S AQAQPG=AQAQPG+1 I $D(AQAQSTRT) K AQAQSTRT G HEAD1
- I $E(IOST)="C",IO=IO(0) R X:DTIME I $E(X)="^"!('$T) S AQAQQUIT="" Q
- HEAD1 W @IOF
- W AQAQSITE,?58,AQAQDTP,?72,"Page ",AQAQPG,!
- W !,?26,"RECREDENTIALING DUE REPORT",!
- W !,"Name",?28,"Staff Category",?48,"Recredentialing Due Date"
- W !,AQAQ80D,!!
- Q
- DTCV I Y=0 S Y="" Q
- ;BEGIN Y2K FIX BLOCK
- ;S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) Q
- S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700) Q ; Y2000
- ;END Y2K FIX BLOCK
- QUIT Q
- AQAQRE1 ;IHS/ASU/RPL 4/17/89 ;Staff Credentials Recredentialing Due Report-Part 2 ; 11/7/89 10:07 AM [ 07/26/1999 10:21 AM ]
- +1 ;;2.2;STAFF CREDENTIALS;**8**;01 OCT 1992
- +2 ;;AQAQ*2*8;Y2K FIX;CS;2990708
- +3 ;
- START SET AQAQ80D="--------------------------------------------------------------------------------"
- +1 SET Y=DT
- XECUTE ^DD("DD")
- SET AQAQDTP=Y
- +2 SET AQAQSTRT=""
- +3 SET AQAQPG=0
- DO HEAD
- +4 SET AQAQRCDU=""
- FOR I=0:0
- SET AQAQRCDU=$ORDER(^UTILITY($JOB,AQAQRCDU))
- IF AQAQRCDU=""!($DATA(AQAQQUIT))
- QUIT
- DO P1
- +5 GOTO QUIT
- P1 SET Y=AQAQRCDU
- XECUTE ^DD("DD")
- SET AQAQRCDY=Y
- IF AQAQRCDY=0
- SET AQAQRCDY="Never Credentialed"
- +1 SET AQAQDFN=""
- FOR J=0:0
- SET AQAQDFN=$ORDER(^UTILITY($JOB,AQAQRCDU,AQAQDFN))
- IF AQAQDFN=""!($DATA(AQAQQUIT))
- QUIT
- DO P15
- +2 QUIT
- P15 IF $Y>(IOSL-12)
- DO HEAD
- IF $DATA(AQAQQUIT)
- QUIT
- +1 SET AQAQ=^UTILITY($JOB,AQAQRCDU,AQAQDFN)
- +2 SET AQAQNM=$PIECE(AQAQ,"^")
- SET AQAQSC=$PIECE(AQAQ,"^",2)
- SET AQAQMLE=$PIECE(AQAQ,"^",3)
- SET AQAQCME=$PIECE(AQAQ,"^",4)
- SET AQAQHSV=$PIECE(AQAQ,"^",5)
- SET AQAQCAD=$PIECE(AQAQ,"^",6)
- +3 SET Y=AQAQMLE
- DO DTCV
- SET AQAQMLEY=Y
- +4 SET X1=AQAQMLE
- SET X2=365+1
- DO C^%DTC
- SET AQAQMLED=X
- SET AQAQMLEO=$SELECT(DT<X:"",1:"*******")
- +5 SET Y=AQAQMLED
- DO DTCV
- SET AQAQMLED=Y
- +6 SET Y=AQAQCME
- DO DTCV
- SET AQAQCMEY=Y
- +7 SET AQAQ1CAD=0
- IF 'AQAQCME
- SET AQAQ1CAD=$ORDER(^AQAQ(AQAQDFN,9,0))
- IF AQAQ1CAD=""
- SET AQAQ1CAD=0
- +8 IF AQAQ1CAD
- SET AQAQ1CAD=$PIECE(^AQAQ(AQAQDFN,9,AQAQ1CAD,0),"^")
- +9 SET X1=$SELECT(AQAQCME>0:AQAQCME,1:AQAQ1CAD)
- SET X2=365+1
- DO C^%DTC
- SET AQAQCMED=X
- SET AQAQCMEO=$SELECT(X=0:"",DT<X:"",1:"*******")
- +10 SET Y=AQAQCMED
- DO DTCV
- SET AQAQCMED=Y
- +11 SET Y=AQAQHSV
- DO DTCV
- SET AQAQHSVY=Y
- +12 SET X1=AQAQHSV
- SET X2=(365*2)+1
- DO C^%DTC
- SET AQAQHSVD=X
- SET AQAQHSVO=$SELECT(DT<X:"",1:"*******")
- +13 SET Y=AQAQHSVD
- DO DTCV
- SET AQAQHSVD=Y
- +14 SET Y=AQAQCAD
- XECUTE ^DD("DD")
- SET AQAQCADY=Y
- IF AQAQCADY=0
- SET AQAQCADY="Pending Approval"
- +15 WRITE $EXTRACT(AQAQNM,1,26),?28,$EXTRACT(AQAQSC,1,20),?50,AQAQRCDY
- +16 WRITE !!,?48,"Current",?60,"Due",?70,"Overdue",!,?48,"--------",?60,"--------",?71,"-------"
- +17 WRITE !,?5,"Medical License Expires",?48,AQAQMLEY,?60,AQAQMLED,?71,AQAQMLEO,!
- +18 WRITE ?5,"CME Summary Last Updated",?48,AQAQCMEY,?60,AQAQCMED,?71,AQAQCMEO,!
- +19 WRITE ?5,"Last Health Status Verification",?48,AQAQHSVY,?60,AQAQHSVD,?71,AQAQHSVO,!
- +20 WRITE !,?5,"Board Certification:"
- IF '$DATA(^AQAQ(AQAQDFN,1))
- WRITE " No Board Certification on file."
- GOTO P2
- +21 WRITE ?33,"Certification",?50,"Verification",!,?5,"--------------------------",?33,"-------------",?50,"------------"
- +22 SET AQAQBC=0
- FOR L=0:0
- SET AQAQBC=$ORDER(^AQAQ(AQAQDFN,1,AQAQBC))
- IF AQAQBC=""
- QUIT
- DO P3
- P2 WRITE !!,?5,"Credentials Last Approved: ",AQAQCADY,!!!
- +1 QUIT
- P3 SET AQAQBRD=^AQAQ(AQAQDFN,1,AQAQBC,0)
- IF AQAQBRD=""
- QUIT
- +1 SET Y=$PIECE(AQAQBRD,"^")
- XECUTE ^DD("DD")
- SET AQAQBRDY=Y
- IF AQAQBRDY=0
- SET AQAQBRDY=""
- P31 SET Y=$PIECE(AQAQBRD,"^",3)
- XECUTE ^DD("DD")
- SET AQAQBRDD=Y
- IF AQAQBRDD=0
- SET AQAQBRDD=""
- +1 SET AQAQBRD=$PIECE(AQAQBRD,"^",2)
- IF AQAQBRD=""
- QUIT
- SET AQAQBRD=$PIECE(^AQAQBD(AQAQBRD,0),"^")
- +2 WRITE !,?5,$EXTRACT(AQAQBRD,1,20),?33,AQAQBRDY,?48,AQAQBRDD
- +3 QUIT
- HEAD SET AQAQPG=AQAQPG+1
- IF $DATA(AQAQSTRT)
- KILL AQAQSTRT
- GOTO HEAD1
- +1 IF $EXTRACT(IOST)="C"
- IF IO=IO(0)
- READ X:DTIME
- IF $EXTRACT(X)="^"!('$TEST)
- SET AQAQQUIT=""
- QUIT
- HEAD1 WRITE @IOF
- +1 WRITE AQAQSITE,?58,AQAQDTP,?72,"Page ",AQAQPG,!
- +2 WRITE !,?26,"RECREDENTIALING DUE REPORT",!
- +3 WRITE !,"Name",?28,"Staff Category",?48,"Recredentialing Due Date"
- +4 WRITE !,AQAQ80D,!!
- +5 QUIT
- DTCV IF Y=0
- SET Y=""
- QUIT
- +1 ;BEGIN Y2K FIX BLOCK
- +2 ;S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3) Q
- +3 ; Y2000
- SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700)
- QUIT
- +4 ;END Y2K FIX BLOCK
- QUIT QUIT
