- ASDNAA ; IHS/ADC/PDW/ENM - NEXT AVAIL APPT REPORT ; [ 03/25/1999 11:48 AM ]
- ;;5.0;IHS SCHEDULING;;MAR 25, 1999
- ;
- S %ZIS="PQ" D ^%ZIS G END:POP
- I $D(IO("Q")) D Q
- . S ZTRTN="START^ASDNAA",ZTDESC="NEXT AVAIL APPT"
- . D ^%ZTLOAD K ZTSK,IO("Q") D HOME^%ZIS,END
- ;
- START ;EP; called by ztload
- U IO D LOOP,PRINT,END Q
- ;
- ;
- LOOP ; -- loop thru clinics for appts
- NEW ASDC,ASDT,ASDS,I,J,ASDCT,X
- K ^TMP("ASDNAA",$J) S ASDC=0
- F S ASDC=$O(^SC(ASDC)) Q:'ASDC D
- . Q:'$$ACTV^ASDUT(ASDC) ;inactive
- . S ASDT=DT-.0001,ASDEND=$$FMADD^XLFDT(DT,13)
- . F S ASDT=$O(^SC(ASDC,"ST",ASDT)) Q:'ASDT!(ASDT>ASDEND) D
- .. S ASDS=$G(^SC(ASDC,"ST",ASDT,1)) Q:ASDS=""
- .. Q:ASDS["CANCELLED"
- .. S ASDS=$P(ASDS,"|",2,999)
- .. F I="|","[","]","*"," ","0" S ASDS=$$STRIP^XLFSTR(ASDS,I)
- .. ;
- .. ; -- count up appts left
- .. S ASDCT=0
- .. F I=1:1:9 Q:ASDS="" D
- ... S X=ASDS F J=1:1 Q:X="" S:$E(X)=I ASDCT=ASDCT+I S X=$E(X,2,99)
- ... S ASDS=$$STRIP^XLFSTR(ASDS,I)
- .. ;
- .. ; -- sort by prin clinic and date
- .. S ^TMP("ASDNAA",$J,$$PC(ASDC),$$CLA(ASDC),ASDT)=ASDCT
- Q
- ;
- PRINT ; -- loop thru ^tmp and print
- NEW ASDPC,ASDC,ASDT
- S ASDPG=0,ASDQ="" D DAYS,HED
- S ASDPC=0
- F S ASDPC=$O(^TMP("ASDNAA",$J,ASDPC)) Q:ASDPC=""!(ASDQ=U) D
- . S ASDC=0
- . F S ASDC=$O(^TMP("ASDNAA",$J,ASDPC,ASDC)) Q:ASDC=""!(ASDQ=U) D
- .. I $Y>(IOSL-4) D NEWPG Q:ASDQ=U
- .. I ASDPC'=ASDC,$$FIRST W !!,"Principal Clinic: ",ASDPC
- .. I ASDPC=ASDC W !
- .. W !,ASDC,?8,"|"
- .. S ASDT=0 F S ASDT=$O(ASDAYS(ASDT)) Q:ASDT=""!(ASDQ=U) D
- ... W $J($G(^TMP("ASDNAA",$J,ASDPC,ASDC,ASDT)),3)," |"
- Q
- ;
- END ; -- eoj
- I IOST["C-",$G(ASDQ)'=U D PRTOPT^ASDVAR
- K ASDEND,ASDQ,ASDPG,DIR,ASDAYS K ^TMP("ASDNAA",$J) D ^%ZISC Q
- ;
- NEWPG ; -- end of page control
- I IOST'["C-" D HED Q
- K DIR S DIR(0)="E" D ^DIR S ASDQ=X
- I ASDQ'=U D HED
- Q
- ;
- HED ; -- heading
- NEW X
- I ASDPG>0!(IOST["C-") W @IOF
- W !!?20,"NUMBER OF APPTS AVAILABLE BY CLINIC AND DATE"
- S ASDPG=ASDPG+1 W ?70,"Page ",ASDPG
- S X=$$FMTE^XLFDT(DT)_" to "_$$FMTE^XLFDT(ASDEND)
- W !?(80-$L(X)/2),X,!
- W !?8,"| " S X=0 F S X=$O(ASDAYS(X)) Q:X="" W $E(X,6,7)," | "
- W !,$$REPEAT^XLFSTR("=",80)
- Q
- ;
- DAYS ; -- creates array of date range
- NEW X
- K ASDAYS S ASDAYS(DT)="",X=DT
- F S X=$$FMADD^XLFDT(X,1) Q:X>ASDEND S ASDAYS(X)=""
- Q
- ;
- CLA(C) ; -- returns clinic abbrev
- Q $S($P(^SC(C,0),U,2)]"":$P(^(0),U,2),1:$E($$CLN(C),1,8))
- ;
- CLN(C) ; -- returns clinic's name
- Q $P(^SC(C,0),U)
- ;
- PC(C) ; -- returns clinic's prin clinic
- NEW X S X=$P($G(^SC(C,"SL")),U,5)
- Q $S(X="":"none",1:$$CLN(X))
- ;
- FIRST() ; -- returns 1 if first under prin clinic
- I ASDC=$O(^TMP("ASDNAA",$J,ASDPC,0)) Q 1
- Q 0
- ASDNAA ; IHS/ADC/PDW/ENM - NEXT AVAIL APPT REPORT ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.0;IHS SCHEDULING;;MAR 25, 1999
- +2 ;
- +3 SET %ZIS="PQ"
- DO ^%ZIS
- IF POP
- GOTO END
- +4 IF $DATA(IO("Q"))
- Begin DoDot:1
- +5 SET ZTRTN="START^ASDNAA"
- SET ZTDESC="NEXT AVAIL APPT"
- +6 DO ^%ZTLOAD
- KILL ZTSK,IO("Q")
- DO HOME^%ZIS
- DO END
- End DoDot:1
- QUIT
- +7 ;
- START ;EP; called by ztload
- +1 USE IO
- DO LOOP
- DO PRINT
- DO END
- QUIT
- +2 ;
- +3 ;
- LOOP ; -- loop thru clinics for appts
- +1 NEW ASDC,ASDT,ASDS,I,J,ASDCT,X
- +2 KILL ^TMP("ASDNAA",$JOB)
- SET ASDC=0
- +3 FOR
- SET ASDC=$ORDER(^SC(ASDC))
- IF 'ASDC
- QUIT
- Begin DoDot:1
- +4 ;inactive
- IF '$$ACTV^ASDUT(ASDC)
- QUIT
- +5 SET ASDT=DT-.0001
- SET ASDEND=$$FMADD^XLFDT(DT,13)
- +6 FOR
- SET ASDT=$ORDER(^SC(ASDC,"ST",ASDT))
- IF 'ASDT!(ASDT>ASDEND)
- QUIT
- Begin DoDot:2
- +7 SET ASDS=$GET(^SC(ASDC,"ST",ASDT,1))
- IF ASDS=""
- QUIT
- +8 IF ASDS["CANCELLED"
- QUIT
- +9 SET ASDS=$PIECE(ASDS,"|",2,999)
- +10 FOR I="|","[","]","*"," ","0"
- SET ASDS=$$STRIP^XLFSTR(ASDS,I)
- +11 ;
- +12 ; -- count up appts left
- +13 SET ASDCT=0
- +14 FOR I=1:1:9
- IF ASDS=""
- QUIT
- Begin DoDot:3
- +15 SET X=ASDS
- FOR J=1:1
- IF X=""
- QUIT
- IF $EXTRACT(X)=I
- SET ASDCT=ASDCT+I
- SET X=$EXTRACT(X,2,99)
- +16 SET ASDS=$$STRIP^XLFSTR(ASDS,I)
- End DoDot:3
- +17 ;
- +18 ; -- sort by prin clinic and date
- +19 SET ^TMP("ASDNAA",$JOB,$$PC(ASDC),$$CLA(ASDC),ASDT)=ASDCT
- End DoDot:2
- End DoDot:1
- +20 QUIT
- +21 ;
- PRINT ; -- loop thru ^tmp and print
- +1 NEW ASDPC,ASDC,ASDT
- +2 SET ASDPG=0
- SET ASDQ=""
- DO DAYS
- DO HED
- +3 SET ASDPC=0
- +4 FOR
- SET ASDPC=$ORDER(^TMP("ASDNAA",$JOB,ASDPC))
- IF ASDPC=""!(ASDQ=U)
- QUIT
- Begin DoDot:1
- +5 SET ASDC=0
- +6 FOR
- SET ASDC=$ORDER(^TMP("ASDNAA",$JOB,ASDPC,ASDC))
- IF ASDC=""!(ASDQ=U)
- QUIT
- Begin DoDot:2
- +7 IF $Y>(IOSL-4)
- DO NEWPG
- IF ASDQ=U
- QUIT
- +8 IF ASDPC'=ASDC
- IF $$FIRST
- WRITE !!,"Principal Clinic: ",ASDPC
- +9 IF ASDPC=ASDC
- WRITE !
- +10 WRITE !,ASDC,?8,"|"
- +11 SET ASDT=0
- FOR
- SET ASDT=$ORDER(ASDAYS(ASDT))
- IF ASDT=""!(ASDQ=U)
- QUIT
- Begin DoDot:3
- +12 WRITE $JUSTIFY($GET(^TMP("ASDNAA",$JOB,ASDPC,ASDC,ASDT)),3)," |"
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 QUIT
- +14 ;
- END ; -- eoj
- +1 IF IOST["C-"
- IF $GET(ASDQ)'=U
- DO PRTOPT^ASDVAR
- +2 KILL ASDEND,ASDQ,ASDPG,DIR,ASDAYS
- KILL ^TMP("ASDNAA",$JOB)
- DO ^%ZISC
- QUIT
- +3 ;
- NEWPG ; -- end of page control
- +1 IF IOST'["C-"
- DO HED
- QUIT
- +2 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- SET ASDQ=X
- +3 IF ASDQ'=U
- DO HED
- +4 QUIT
- +5 ;
- HED ; -- heading
- +1 NEW X
- +2 IF ASDPG>0!(IOST["C-")
- WRITE @IOF
- +3 WRITE !!?20,"NUMBER OF APPTS AVAILABLE BY CLINIC AND DATE"
- +4 SET ASDPG=ASDPG+1
- WRITE ?70,"Page ",ASDPG
- +5 SET X=$$FMTE^XLFDT(DT)_" to "_$$FMTE^XLFDT(ASDEND)
- +6 WRITE !?(80-$LENGTH(X)/2),X,!
- +7 WRITE !?8,"| "
- SET X=0
- FOR
- SET X=$ORDER(ASDAYS(X))
- IF X=""
- QUIT
- WRITE $EXTRACT(X,6,7)," | "
- +8 WRITE !,$$REPEAT^XLFSTR("=",80)
- +9 QUIT
- +10 ;
- DAYS ; -- creates array of date range
- +1 NEW X
- +2 KILL ASDAYS
- SET ASDAYS(DT)=""
- SET X=DT
- +3 FOR
- SET X=$$FMADD^XLFDT(X,1)
- IF X>ASDEND
- QUIT
- SET ASDAYS(X)=""
- +4 QUIT
- +5 ;
- CLA(C) ; -- returns clinic abbrev
- +1 QUIT $SELECT($PIECE(^SC(C,0),U,2)]"":$PIECE(^(0),U,2),1:$EXTRACT($$CLN(C),1,8))
- +2 ;
- CLN(C) ; -- returns clinic's name
- +1 QUIT $PIECE(^SC(C,0),U)
- +2 ;
- PC(C) ; -- returns clinic's prin clinic
- +1 NEW X
- SET X=$PIECE($GET(^SC(C,"SL")),U,5)
- +2 QUIT $SELECT(X="":"none",1:$$CLN(X))
- +3 ;
- FIRST() ; -- returns 1 if first under prin clinic
- +1 IF ASDC=$ORDER(^TMP("ASDNAA",$JOB,ASDPC,0))
- QUIT 1
- +2 QUIT 0
