- 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
