AQAQRE ;IHS/ASU/RPL 4/17/89;Staff Credentials Recredentialing Due Report ; 11/7/89 10:10 AM
;;STAFF CREDENTIALS Version 1.1;11/7/89
;
START S AQAQSITE=$P(^DIC(4,DUZ(2),0),"^",1)
ZIS W !! S %IS="Q" D ^%ZIS G:POP QUIT I '$D(IO("Q")) U IO G DQUE
QUE K IO("Q"),IO("S") I IO=IO(0) W !,"Cannot Queue to Screen or Slave Printer!",! G ZIS
S ZTRTN="DQUE^AQAQRE",ZTDESC="RECREDENTIALING DUE STAFF CREDENTIALS REPORT" S ZTSAVE("AQAQSITE")=""
D ^%ZTLOAD G QUIT
DQUE K ^UTILITY($J)
S AQAQSET=^DD(9002155,1,0),AQAQSET=$P(AQAQSET,"^",3),AQAQCTR=$L(AQAQSET,":")-1
F I=1:1:AQAQCTR S AQAQS=$P(AQAQSET,";",I) S AQAQ1=$P(AQAQS,":"),AQAQ2=$P(AQAQS,":",2) S AQAQS(AQAQ1)=AQAQ2
S AQAQDFN=0 F I=0:0 S AQAQDFN=$O(^AQAQ(AQAQDFN)) Q:AQAQDFN'=+AQAQDFN D C0
G PRINT
C0 S AQAQNM=$P(^DIC(16,AQAQDFN,0),"^")
I '$D(^AQAQ(AQAQDFN,8)) S AQAQRCDU=0 G C000
S AQAQRCDU=$P(^AQAQ(AQAQDFN,8),"^",2) S:AQAQRCDU="" AQAQRCDU=0
C000 S AQAQSC=$P(^AQAQ(AQAQDFN,0),"^",2) S AQAQSC=$S(AQAQSC]"":AQAQS(AQAQSC),1:"<No Staff Category on File>")
C00 I '$D(^AQAQ(AQAQDFN,3)) S AQAQMLE=0 G C01
K AQAQMLE S AQAQ3=0 F J=0:0 S AQAQ3=$O(^AQAQ(AQAQDFN,3,AQAQ3)) Q:'AQAQ3 S AQAQMLE=$P(^(AQAQ3,0),"^")
S:'$D(AQAQMLE) AQAQMLE=0 S:AQAQMLE="" AQAQMLE=0
C01 I '$D(^AQAQ(AQAQDFN,6)) S AQAQHSV=0 G C02
K AQAQHSV S AQAQ6=0 F J=0:0 S AQAQ6=$O(^AQAQ(AQAQDFN,6,AQAQ6)) Q:'AQAQ6 S AQAQHSV=$P(^(AQAQ6,0),"^")
S:'$D(AQAQHSV) AQAQHSV=0 S:AQAQHSV="" AQAQHSV=0
C02 I '$D(^AQAQ(AQAQDFN,9)) S AQAQCAD=0 G C03
K AQAQCAD S AQAQ9=0 F J=0:0 S AQAQ9=$O(^AQAQ(AQAQDFN,9,AQAQ9)) Q:'AQAQ9 S AQAQCAD=$P(^(AQAQ9,0),"^")
S:'$D(AQAQCAD) AQAQCAD=0 S:AQAQCAD="" AQAQCAD=0
C03 I '$D(^AQAQ(AQAQDFN,4)) S AQAQCMED=0 G C04
K AQAQCMED S AQAQ4=0 F J=0:0 S AQAQ4=$O(^AQAQ(AQAQDFN,4,AQAQ4)) Q:'AQAQ4 S AQAQCMED=$P(^(AQAQ4,0),"^")
S:'$D(AQAQCMED) AQAQCMED=0 S:AQAQCMED="" AQAQCMED=0
C04 S ^UTILITY($J,AQAQRCDU,AQAQDFN)=AQAQNM_"^"_AQAQSC_"^"_AQAQMLE_"^"_AQAQCMED_"^"_AQAQHSV_"^"_AQAQCAD
Q
;
PRINT D ^AQAQRE1
QUIT2 I $D(ZTSK) K ^%ZTSK(ZTSK)
QUIT I $D(IOST),'$D(AQAQQUIT),$D(IO),$E(IOST)="C",IO=IO(0) R X:DTIME
W @IOF
X ^%ZIS("C") K Y,DIC,%DT,^UTILITY($J),ZTSK,IO("Q"),IO("S"),II,I,J,K,JJ,L,M,X
K AQAQ,AQAQQUIT,AQAQ1,AQAQ2,AQAQ3,AQAQ6,AQAQ80D,AQAQ9,AQAQCAD,AQAQCTR,AQAQDFN,AQAQDTP,AQAQHSV,AQAQNM,AQAQPG,AQAQS,AQAQSC,AQAQSET,AQAQSITE,AQAQBC,AQAQBRD,AQAQBRDD,AQAQBRDY
K AQAQ1CAD,AQAQ4,AQAQCADY,AQAQCME,AQAQCMED,AQAQCMEO,AQAQCMEY,AQAQHSVD,AQAQHSVO,AQAQHSVY,AQAQMLE,AQAQMLED,AQAQMLEO,AQAQMLEY,AQAQRCDU,AQAQRCDY
Q
AQAQRE ;IHS/ASU/RPL 4/17/89;Staff Credentials Recredentialing Due Report ; 11/7/89 10:10 AM
+1 ;;STAFF CREDENTIALS Version 1.1;11/7/89
+2 ;
START SET AQAQSITE=$PIECE(^DIC(4,DUZ(2),0),"^",1)
ZIS WRITE !!
SET %IS="Q"
DO ^%ZIS
IF POP
GOTO QUIT
IF '$DATA(IO("Q"))
USE IO
GOTO DQUE
QUE KILL IO("Q"),IO("S")
IF IO=IO(0)
WRITE !,"Cannot Queue to Screen or Slave Printer!",!
GOTO ZIS
+1 SET ZTRTN="DQUE^AQAQRE"
SET ZTDESC="RECREDENTIALING DUE STAFF CREDENTIALS REPORT"
SET ZTSAVE("AQAQSITE")=""
+2 DO ^%ZTLOAD
GOTO QUIT
DQUE KILL ^UTILITY($JOB)
+1 SET AQAQSET=^DD(9002155,1,0)
SET AQAQSET=$PIECE(AQAQSET,"^",3)
SET AQAQCTR=$LENGTH(AQAQSET,":")-1
+2 FOR I=1:1:AQAQCTR
SET AQAQS=$PIECE(AQAQSET,";",I)
SET AQAQ1=$PIECE(AQAQS,":")
SET AQAQ2=$PIECE(AQAQS,":",2)
SET AQAQS(AQAQ1)=AQAQ2
+3 SET AQAQDFN=0
FOR I=0:0
SET AQAQDFN=$ORDER(^AQAQ(AQAQDFN))
IF AQAQDFN'=+AQAQDFN
QUIT
DO C0
+4 GOTO PRINT
C0 SET AQAQNM=$PIECE(^DIC(16,AQAQDFN,0),"^")
+1 IF '$DATA(^AQAQ(AQAQDFN,8))
SET AQAQRCDU=0
GOTO C000
+2 SET AQAQRCDU=$PIECE(^AQAQ(AQAQDFN,8),"^",2)
IF AQAQRCDU=""
SET AQAQRCDU=0
C000 SET AQAQSC=$PIECE(^AQAQ(AQAQDFN,0),"^",2)
SET AQAQSC=$SELECT(AQAQSC]"":AQAQS(AQAQSC),1:"<No Staff Category on File>")
C00 IF '$DATA(^AQAQ(AQAQDFN,3))
SET AQAQMLE=0
GOTO C01
+1 KILL AQAQMLE
SET AQAQ3=0
FOR J=0:0
SET AQAQ3=$ORDER(^AQAQ(AQAQDFN,3,AQAQ3))
IF 'AQAQ3
QUIT
SET AQAQMLE=$PIECE(^(AQAQ3,0),"^")
+2 IF '$DATA(AQAQMLE)
SET AQAQMLE=0
IF AQAQMLE=""
SET AQAQMLE=0
C01 IF '$DATA(^AQAQ(AQAQDFN,6))
SET AQAQHSV=0
GOTO C02
+1 KILL AQAQHSV
SET AQAQ6=0
FOR J=0:0
SET AQAQ6=$ORDER(^AQAQ(AQAQDFN,6,AQAQ6))
IF 'AQAQ6
QUIT
SET AQAQHSV=$PIECE(^(AQAQ6,0),"^")
+2 IF '$DATA(AQAQHSV)
SET AQAQHSV=0
IF AQAQHSV=""
SET AQAQHSV=0
C02 IF '$DATA(^AQAQ(AQAQDFN,9))
SET AQAQCAD=0
GOTO C03
+1 KILL AQAQCAD
SET AQAQ9=0
FOR J=0:0
SET AQAQ9=$ORDER(^AQAQ(AQAQDFN,9,AQAQ9))
IF 'AQAQ9
QUIT
SET AQAQCAD=$PIECE(^(AQAQ9,0),"^")
+2 IF '$DATA(AQAQCAD)
SET AQAQCAD=0
IF AQAQCAD=""
SET AQAQCAD=0
C03 IF '$DATA(^AQAQ(AQAQDFN,4))
SET AQAQCMED=0
GOTO C04
+1 KILL AQAQCMED
SET AQAQ4=0
FOR J=0:0
SET AQAQ4=$ORDER(^AQAQ(AQAQDFN,4,AQAQ4))
IF 'AQAQ4
QUIT
SET AQAQCMED=$PIECE(^(AQAQ4,0),"^")
+2 IF '$DATA(AQAQCMED)
SET AQAQCMED=0
IF AQAQCMED=""
SET AQAQCMED=0
C04 SET ^UTILITY($JOB,AQAQRCDU,AQAQDFN)=AQAQNM_"^"_AQAQSC_"^"_AQAQMLE_"^"_AQAQCMED_"^"_AQAQHSV_"^"_AQAQCAD
+1 QUIT
+2 ;
PRINT DO ^AQAQRE1
QUIT2 IF $DATA(ZTSK)
KILL ^%ZTSK(ZTSK)
QUIT IF $DATA(IOST)
IF '$DATA(AQAQQUIT)
IF $DATA(IO)
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
READ X:DTIME
+1 WRITE @IOF
+2 XECUTE ^%ZIS("C")
KILL Y,DIC,%DT,^UTILITY($JOB),ZTSK,IO("Q"),IO("S"),II,I,J,K,JJ,L,M,X
+3 KILL AQAQ,AQAQQUIT,AQAQ1,AQAQ2,AQAQ3,AQAQ6,AQAQ80D,AQAQ9,AQAQCAD,AQAQCTR,AQAQDFN,AQAQDTP,AQAQHSV,AQAQNM,AQAQPG,AQAQS,AQAQSC,AQAQSET,AQAQSITE,AQAQBC,AQAQBRD,AQAQBRDD,AQAQBRDY
+4 KILL AQAQ1CAD,AQAQ4,AQAQCADY,AQAQCME,AQAQCMED,AQAQCMEO,AQAQCMEY,AQAQHSVD,AQAQHSVO,AQAQHSVY,AQAQMLE,AQAQMLED,AQAQMLEO,AQAQMLEY,AQAQRCDU,AQAQRCDY
+5 QUIT
