AQAQREAP ;IHS/ANMC/LJF - PENDING REAPPOINTMENTS; [ 01/07/94 10:57 AM ]
;;2.2;STAFF CREDENTIALS;**5**;01 OCT 1992
;
;****> prints summary for all pending reappointment applications
W @IOF,!!?20,"PENDING REAPPOINTMENT APPLICATIONS",!!
W ?5,"This report will print summaries on each provider whose"
W !,"reappointment application is due, not completed or overdue."
W !,"The summaries will print in alphabetical order.",!!
;
K DIR S DIR(0)="N0:1:12",DIR("B")=1
S DIR("A")="Print Reappointments to come due how many months from now?"
S DIR("?",1)="Enter 0 (zero) to see only those due NOW;"
S DIR("?",2)="Enter 1 to see those due in the coming month;"
S DIR("?",3)="Enter 2 to see those due in the next 2 months;"
S DIR("?",4)="And so on up to 12 months."
S DIR("?")="All reports include those currently OVERDUE"
D ^DIR G END:$D(DIRUT)
S X1=DT,X2=Y*30 D C^%DTC
S X1=X,X2=-730 D C^%DTC S AQAQDUE=X
;
;***> select type of report
TYPE K DIR S DIR("A",1)="Select Sorting Order for Report:"
S DIR("A",2)=" 1. ALPHABETICALLY (By Provider Name)"
S DIR("A",3)=" 2. By PROVIDER CLASS"
S DIR("A",4)=" 3. By STAFF CATEGORY"
SELECT S DIR("A")="Select (1, 2, or 3): ",DIR(0)="NAO^1:3" D ^DIR
G END:$D(DTOUT),END:X="",END:$D(DUOUT),TYPE:Y=-1 S AQAQTYP=Y
I AQAQTYP=1 S AQAQSRT="" G DEV
;
ALL ;***> choose one or all classes or categories
K DIR S DIR(0)="Y"
S DIR("A")=$S(AQAQTYP=2:"Print for All Classes",1:"Print for All Categories")
S DIR("B")="NO" D ^DIR I Y=1 S AQAQSRT="ALL" G DEV ;all wards or serv
I $D(DIRUT) G END ;check for timeout,"^", or null
;
ONE ;***> choose which class or category to print
I AQAQTYP=2 D G END:'$D(AQAQSRT) G DEV
.K DIR,AQAQSRT S DIR(0)="PO^7:EMQZ" D ^DIR
.Q:$D(DTOUT) Q:X="" Q:$D(DUOUT) Q:Y=-1
.I $D(^DIC(42,+Y,"I")),$P(^("I"),U)="I" W ?40,"** INACTIVE WARD **" Q
.S AQAQSRT=Y
E D G END:'$D(AQAQSRT)
.K DIR,AQAQSRT S DIR(0)="9002165,.02" D ^DIR
.Q:$D(DTOUT) Q:X="" Q:$D(DUOUT) Q:Y=-1
.S AQAQSRT=Y
;
DEV S %ZIS="NPQ" D ^%ZIS G END:POP I '$D(IO("Q")) G REAP1
K IO("Q") S ZTRTN="REAP1^AQAQREAP",ZTDESC="PENDING REAPPOINTMENTS"
F AQAQI="AQAQDUE","AQAQTYP","AQAQSRT" S ZTSAVE(AQAQI)=""
D ^%ZTLOAD K ZTSK,AQAQDUE,AQAQTYP,AQAQSRT D ^%ZISC Q
;
REAP1 ;**> set variables then call FileMan print
S L=0,DIC=9002165,FLDS="[AQAQINQUIRE]",IOP=ION
S BY="@NAME",(TO,FR)="" ;alphabetical list
I AQAQTYP=2 S BY="@NAME:CLASS,@NAME" I +AQAQSRT S (TO,FR)=$P(AQAQSRT,U,2)
I AQAQTYP=3 S BY="@STAFF CATEGORY,@NAME" I AQAQSRT'="ALL" S TO=Y(0)_"Z",FR=Y(0) ;IHS/OKCRDC/BJH 10/5/93 PATCH 5
S DIS(0)="D ^AQAQDUE I AQAQLAST<AQAQDUE"
D EN1^DIP
I '$D(ZTQUEUED) K DIR S DIR(0)="E",DIR("A")="RETURN to continue" D ^DIR W @IOF
END W @IOF D ^%ZISC D KILL^AQAQUTIL Q
AQAQREAP ;IHS/ANMC/LJF - PENDING REAPPOINTMENTS; [ 01/07/94 10:57 AM ]
+1 ;;2.2;STAFF CREDENTIALS;**5**;01 OCT 1992
+2 ;
+3 ;****> prints summary for all pending reappointment applications
+4 WRITE @IOF,!!?20,"PENDING REAPPOINTMENT APPLICATIONS",!!
+5 WRITE ?5,"This report will print summaries on each provider whose"
+6 WRITE !,"reappointment application is due, not completed or overdue."
+7 WRITE !,"The summaries will print in alphabetical order.",!!
+8 ;
+9 KILL DIR
SET DIR(0)="N0:1:12"
SET DIR("B")=1
+10 SET DIR("A")="Print Reappointments to come due how many months from now?"
+11 SET DIR("?",1)="Enter 0 (zero) to see only those due NOW;"
+12 SET DIR("?",2)="Enter 1 to see those due in the coming month;"
+13 SET DIR("?",3)="Enter 2 to see those due in the next 2 months;"
+14 SET DIR("?",4)="And so on up to 12 months."
+15 SET DIR("?")="All reports include those currently OVERDUE"
+16 DO ^DIR
IF $DATA(DIRUT)
GOTO END
+17 SET X1=DT
SET X2=Y*30
DO C^%DTC
+18 SET X1=X
SET X2=-730
DO C^%DTC
SET AQAQDUE=X
+19 ;
+20 ;***> select type of report
TYPE KILL DIR
SET DIR("A",1)="Select Sorting Order for Report:"
+1 SET DIR("A",2)=" 1. ALPHABETICALLY (By Provider Name)"
+2 SET DIR("A",3)=" 2. By PROVIDER CLASS"
+3 SET DIR("A",4)=" 3. By STAFF CATEGORY"
SELECT SET DIR("A")="Select (1, 2, or 3): "
SET DIR(0)="NAO^1:3"
DO ^DIR
+1 IF $DATA(DTOUT)
GOTO END
IF X=""
GOTO END
IF $DATA(DUOUT)
GOTO END
IF Y=-1
GOTO TYPE
SET AQAQTYP=Y
+2 IF AQAQTYP=1
SET AQAQSRT=""
GOTO DEV
+3 ;
ALL ;***> choose one or all classes or categories
+1 KILL DIR
SET DIR(0)="Y"
+2 SET DIR("A")=$SELECT(AQAQTYP=2:"Print for All Classes",1:"Print for All Categories")
+3 ;all wards or serv
SET DIR("B")="NO"
DO ^DIR
IF Y=1
SET AQAQSRT="ALL"
GOTO DEV
+4 ;check for timeout,"^", or null
IF $DATA(DIRUT)
GOTO END
+5 ;
ONE ;***> choose which class or category to print
+1 IF AQAQTYP=2
Begin DoDot:1
+2 KILL DIR,AQAQSRT
SET DIR(0)="PO^7:EMQZ"
DO ^DIR
+3 IF $DATA(DTOUT)
QUIT
IF X=""
QUIT
IF $DATA(DUOUT)
QUIT
IF Y=-1
QUIT
+4 IF $DATA(^DIC(42,+Y,"I"))
IF $PIECE(^("I"),U)="I"
WRITE ?40,"** INACTIVE WARD **"
QUIT
+5 SET AQAQSRT=Y
End DoDot:1
IF '$DATA(AQAQSRT)
GOTO END
GOTO DEV
+6 IF '$TEST
Begin DoDot:1
+7 KILL DIR,AQAQSRT
SET DIR(0)="9002165,.02"
DO ^DIR
+8 IF $DATA(DTOUT)
QUIT
IF X=""
QUIT
IF $DATA(DUOUT)
QUIT
IF Y=-1
QUIT
+9 SET AQAQSRT=Y
End DoDot:1
IF '$DATA(AQAQSRT)
GOTO END
+10 ;
DEV SET %ZIS="NPQ"
DO ^%ZIS
IF POP
GOTO END
IF '$DATA(IO("Q"))
GOTO REAP1
+1 KILL IO("Q")
SET ZTRTN="REAP1^AQAQREAP"
SET ZTDESC="PENDING REAPPOINTMENTS"
+2 FOR AQAQI="AQAQDUE","AQAQTYP","AQAQSRT"
SET ZTSAVE(AQAQI)=""
+3 DO ^%ZTLOAD
KILL ZTSK,AQAQDUE,AQAQTYP,AQAQSRT
DO ^%ZISC
QUIT
+4 ;
REAP1 ;**> set variables then call FileMan print
+1 SET L=0
SET DIC=9002165
SET FLDS="[AQAQINQUIRE]"
SET IOP=ION
+2 ;alphabetical list
SET BY="@NAME"
SET (TO,FR)=""
+3 IF AQAQTYP=2
SET BY="@NAME:CLASS,@NAME"
IF +AQAQSRT
SET (TO,FR)=$PIECE(AQAQSRT,U,2)
+4 ;IHS/OKCRDC/BJH 10/5/93 PATCH 5
IF AQAQTYP=3
SET BY="@STAFF CATEGORY,@NAME"
IF AQAQSRT'="ALL"
SET TO=Y(0)_"Z"
SET FR=Y(0)
+5 SET DIS(0)="D ^AQAQDUE I AQAQLAST<AQAQDUE"
+6 DO EN1^DIP
+7 IF '$DATA(ZTQUEUED)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="RETURN to continue"
DO ^DIR
WRITE @IOF
END WRITE @IOF
DO ^%ZISC
DO KILL^AQAQUTIL
QUIT
