AQAQNQ1 ;IHS/ANMC/LJF - MORE CREDENTIALS REPORTS; [ 04/03/95 7:37 AM ]
;;2.2;STAFF CREDENTIALS;**2**;01 OCT 1992
;
MLIC ;EP;****> prints listing of all medical licenses due to expire
W @IOF,!!?20,"MEDICAL LICENSURES DUE TO EXPIRE",!!
W ?5,"This report will print a listing of all medical licenses"
W !,"that are due to expire and those already overdue."
W !,"The report will list the providers in alphabetical order.",!!
;
K DIR S DIR(0)="N0^1:12",DIR("B")=1
S DIR("A")="Print Licenses 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 MEND:$D(DIRUT) S AQAQNUM=Y
S X1=DT,X2=Y*30 D C^%DTC S AQAQDUE=X
;
;***> select type of report
TYPE W ! 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"
S DIR("A")="Select (1, 2, or 3): ",DIR(0)="NAO^1:3" D ^DIR
G MEND:$D(DTOUT),MEND:X="",MEND:$D(DUOUT),TYPE:Y=-1 S AQAQTYP=Y
I AQAQTYP=1 S AQAQSRT="" G MDEV
;
MALL ;***> 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="" G MDEV ;all wards or serv
I $D(DIRUT) G MEND ;check for timeout,"^", or null
;
MCHOOSE ;***> choose which class or category to print
I AQAQTYP=2 D G TYPE:'$D(AQAQSRT) G MDEV
.K DIR,AQAQSRT S DIR(0)="PO^7:EMQZ" D ^DIR
.Q:$D(DTOUT) Q:X="" Q:$D(DUOUT) Q:Y=-1
.S AQAQSRT=$P(Y,U,2)
E D G TYPE:'$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(0)
;
MDEV S %ZIS="NPQ" D ^%ZIS G MEND:POP I '$D(IO("Q")) G MLIC1
K IO("Q") S ZTRTN="MLIC1^AQAQNQ1",ZTDESC="LICENSES DUE TO EXPIRE"
F AQAQI="AQAQDUE","AQAQSRT","AQAQTYP","AQAQNUM" S ZTSAVE(AQAQI)=""
D ^%ZTLOAD D ^%ZISC K ZTSK,AQAQDUE,AQAQSRT,AQAQTYP,AQAQNUM Q
;
MLIC1 ;**> set variables then call FileMan print
S L=0,DIC=9002161.2,FLDS="[AQAQ LICENSE DUE]"
S DHD="W ?0 D MHDR^AQAQNQ1"
I AQAQTYP=1 S BY="@PROVIDER",(TO,FR)=""
I AQAQTYP=2 S BY="@PROVIDER",(TO,FR)=AQAQSRT
I AQAQTYP=3 S BY="STAFF CATEGORY,@PROVIDER",(TO,FR)=AQAQSRT
S DIS(0)="S AQAQX=$P(^AQAQML(D0,0),U,2) I AQAQX]"""",(+$G(^VA(200,AQAQX,""I""))=0)!($G(^VA(200,AQAQX,""I""))>DT)" ;IHS/ORDC/LJF PATCH #2
S IOP=ION,DIS(1)="D LASTMLIC^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
;
;**> eoj
MEND D KILL^AQAQUTIL Q
;
;
MHDR ;**> SUBRTN for report header
W !?8,"*****Confidential Medical Staff Data Covered by Privacy Act*****"
W !,"Medical Licenses DUE TO EXPIRE in the next "_AQAQNUM_" months "
S %H=$H D YX^%DTC W ?60,$P(Y,":",1,2)
W !!,"PROVIDER NAME",?27,"STATE",?39,"EXPIRATION DATE"
W ! S X="",$P(X,"=",80)="" W X,!!
Q
AQAQNQ1 ;IHS/ANMC/LJF - MORE CREDENTIALS REPORTS; [ 04/03/95 7:37 AM ]
+1 ;;2.2;STAFF CREDENTIALS;**2**;01 OCT 1992
+2 ;
MLIC ;EP;****> prints listing of all medical licenses due to expire
+1 WRITE @IOF,!!?20,"MEDICAL LICENSURES DUE TO EXPIRE",!!
+2 WRITE ?5,"This report will print a listing of all medical licenses"
+3 WRITE !,"that are due to expire and those already overdue."
+4 WRITE !,"The report will list the providers in alphabetical order.",!!
+5 ;
+6 KILL DIR
SET DIR(0)="N0^1:12"
SET DIR("B")=1
+7 SET DIR("A")="Print Licenses to come due how many months from now?"
+8 SET DIR("?",1)="Enter 0 (zero) to see only those due NOW;"
+9 SET DIR("?",2)="Enter 1 to see those due in the coming month;"
+10 SET DIR("?",3)="Enter 2 to see those due in the next 2 months;"
+11 SET DIR("?",4)="And so on up to 12 months."
+12 SET DIR("?")="All reports include those currently OVERDUE"
+13 DO ^DIR
IF $DATA(DIRUT)
GOTO MEND
SET AQAQNUM=Y
+14 SET X1=DT
SET X2=Y*30
DO C^%DTC
SET AQAQDUE=X
+15 ;
+16 ;***> select type of report
TYPE WRITE !
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"
+4 SET DIR("A")="Select (1, 2, or 3): "
SET DIR(0)="NAO^1:3"
DO ^DIR
+5 IF $DATA(DTOUT)
GOTO MEND
IF X=""
GOTO MEND
IF $DATA(DUOUT)
GOTO MEND
IF Y=-1
GOTO TYPE
SET AQAQTYP=Y
+6 IF AQAQTYP=1
SET AQAQSRT=""
GOTO MDEV
+7 ;
MALL ;***> 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=""
GOTO MDEV
+4 ;check for timeout,"^", or null
IF $DATA(DIRUT)
GOTO MEND
+5 ;
MCHOOSE ;***> 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 SET AQAQSRT=$PIECE(Y,U,2)
End DoDot:1
IF '$DATA(AQAQSRT)
GOTO TYPE
GOTO MDEV
+5 IF '$TEST
Begin DoDot:1
+6 KILL DIR,AQAQSRT
SET DIR(0)="9002165,.02"
DO ^DIR
+7 IF $DATA(DTOUT)
QUIT
IF X=""
QUIT
IF $DATA(DUOUT)
QUIT
IF Y=-1
QUIT
+8 SET AQAQSRT=Y(0)
End DoDot:1
IF '$DATA(AQAQSRT)
GOTO TYPE
+9 ;
MDEV SET %ZIS="NPQ"
DO ^%ZIS
IF POP
GOTO MEND
IF '$DATA(IO("Q"))
GOTO MLIC1
+1 KILL IO("Q")
SET ZTRTN="MLIC1^AQAQNQ1"
SET ZTDESC="LICENSES DUE TO EXPIRE"
+2 FOR AQAQI="AQAQDUE","AQAQSRT","AQAQTYP","AQAQNUM"
SET ZTSAVE(AQAQI)=""
+3 DO ^%ZTLOAD
DO ^%ZISC
KILL ZTSK,AQAQDUE,AQAQSRT,AQAQTYP,AQAQNUM
QUIT
+4 ;
MLIC1 ;**> set variables then call FileMan print
+1 SET L=0
SET DIC=9002161.2
SET FLDS="[AQAQ LICENSE DUE]"
+2 SET DHD="W ?0 D MHDR^AQAQNQ1"
+3 IF AQAQTYP=1
SET BY="@PROVIDER"
SET (TO,FR)=""
+4 IF AQAQTYP=2
SET BY="@PROVIDER"
SET (TO,FR)=AQAQSRT
+5 IF AQAQTYP=3
SET BY="STAFF CATEGORY,@PROVIDER"
SET (TO,FR)=AQAQSRT
+6 ;IHS/ORDC/LJF PATCH #2
SET DIS(0)="S AQAQX=$P(^AQAQML(D0,0),U,2) I AQAQX]"""",(+$G(^VA(200,AQAQX,""I""))=0)!($G(^VA(200,AQAQX,""I""))>DT)"
+7 SET IOP=ION
SET DIS(1)="D LASTMLIC^AQAQDUE I AQAQLAST<AQAQDUE"
+8 DO EN1^DIP
+9 IF '$DATA(ZTQUEUED)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="RETURN to continue"
DO ^DIR
WRITE @IOF
+10 ;
+11 ;**> eoj
MEND DO KILL^AQAQUTIL
QUIT
+1 ;
+2 ;
MHDR ;**> SUBRTN for report header
+1 WRITE !?8,"*****Confidential Medical Staff Data Covered by Privacy Act*****"
+2 WRITE !,"Medical Licenses DUE TO EXPIRE in the next "_AQAQNUM_" months "
+3 SET %H=$HOROLOG
DO YX^%DTC
WRITE ?60,$PIECE(Y,":",1,2)
+4 WRITE !!,"PROVIDER NAME",?27,"STATE",?39,"EXPIRATION DATE"
+5 WRITE !
SET X=""
SET $PIECE(X,"=",80)=""
WRITE X,!!
+6 QUIT
