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
