ASDPCNA ; IHS/ADC/PDW/ENM - # DAYS TIL NEXT APPT ; [ 03/25/1999 11:48 AM ]
;;5.0;IHS SCHEDULING;;MAR 25, 1999
;
NEW SDAY,PC,X,J,SC,Y,Z,POP
A ; -- driver
D DEV Q:POP I $D(IO("Q")) D QUE,Q Q
EN D HD,SC,Q Q
;
SC ; -- loop principle clinic x-ref
U IO S POP=0
S PC=0 F S PC=$O(^SC("AIHSPC",PC)) Q:'PC D PC D Q:POP
. S SC=0 F S SC=$O(^SC("AIHSPC",PC,SC)) Q:'SC D:$$CK DAY Q:POP
Q:POP W !,"*No Principal Clinic"
S SC=0 F S SC=$O(^SC(SC)) Q:'SC D Q:POP
. Q:'$$NPC Q:'$$CK D DAY
Q
;
DAY ; -- loop visit days / clinic and print next appt
S SDAY=$$SD F S SDAY=$O(^SC(SC,"ST",SDAY)) Q:'SDAY Q:$$NA
I 'SDAY W ?26,$E($P(^SC(SC,0),U),1,30),?57,"none",! D Q
. I $Y>(IOSL-6) D:IOST["C-" Q:POP D HD Q
.. NEW DIR S DIR(0)="E" D ^DIR S:'Y POP=1
S X=$O(^SC(SC,"ST",SDAY,0)) Q:'X
S Y=$$FMTE^XLFDT(SDAY)
W ?26,$E($P(^SC(SC,0),U),1,30),?57,Y,?71,$J($$D(SDAY),2)," days",!
I $Y>(IOSL-6) D:IOST["C-" Q:POP D HD
. NEW DIR S DIR(0)="E" D ^DIR S:'Y POP=1
Q
;
PC ; -- principle clinic
W !,$E($P(^SC(PC,0),U),1,25) Q
;
DEV ; -- device selection
S %ZIS="PQ" D ^%ZIS K %ZIS Q
;
HD ; -- heading
W @IOF,!!,?2,"Next Available Appointment by Principle Clinic"
N %,%H,%I,X D NOW^%DTC W ?60,%I(1),"/",%I(2),"/",$E(%I(3),2,3)
W " ",$E($P(%,".",2),1,2),":",$E($P(%,".",2),3,4),!!
I $G(PC),$O(^SC("AIHSPC",PC,SC)) W !,$E($P(^SC(PC,0),U),1,16)," ..cont."
Q
;
Q ; -- cleanup
I IOST["C-",'$G(POP) D PRTOPT^ASDVAR
D ^%ZISC,HOME^%ZIS Q
;
QUE ; -- queued output
S ZTRTN="EN^ASDPCNA",ZTDESC="Principle Clinic Next Appointment"
D ^%ZTLOAD Q
;
CK() ; -- active clinic? (yes=true)
NEW X
S X=$G(^SC(SC,"I")) Q:'$D(^SC(SC,"ST")) 0 Q:'$O(^("ST",DT)) 0
Q $S($P(^SC(SC,0),U,3)'="C":0,'X:1,(DT>(X-1))&('$P(X,U,2)):0,1:1)
;
NA() ; -- next appointment
NEW X,Y,Z,J
S Y=$O(^SC(SC,"ST",SDAY,0)) Q:'Y 0
S X="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
S Z=$E(^SC(SC,"ST",SDAY,Y),6,$L(^SC(SC,"ST",SDAY,Y)))
F J=1:1:$L(Z) I $E(X,$F(X,"0"),$L(X))[$E(Z,J) S J=999
Q $S(J=999:1,1:0)
;
NPC() ; -- principle clinic (none=false)
Q $S($P($G(^SC(SC,"SL")),U,5):0,1:1)
;
D(X1,X2,X) ; -- number of days
S X2=DT D ^%DTC Q X
;
SD(X1,X2,X) ; -- start day
S X1=DT,X2=-1 D C^%DTC Q X
ASDPCNA ; IHS/ADC/PDW/ENM - # DAYS TIL NEXT APPT ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;IHS SCHEDULING;;MAR 25, 1999
+2 ;
+3 NEW SDAY,PC,X,J,SC,Y,Z,POP
A ; -- driver
+1 DO DEV
IF POP
QUIT
IF $DATA(IO("Q"))
DO QUE
DO Q
QUIT
EN DO HD
DO SC
DO Q
QUIT
+1 ;
SC ; -- loop principle clinic x-ref
+1 USE IO
SET POP=0
+2 SET PC=0
FOR
SET PC=$ORDER(^SC("AIHSPC",PC))
IF 'PC
QUIT
DO PC
Begin DoDot:1
+3 SET SC=0
FOR
SET SC=$ORDER(^SC("AIHSPC",PC,SC))
IF 'SC
QUIT
IF $$CK
DO DAY
IF POP
QUIT
End DoDot:1
IF POP
QUIT
+4 IF POP
QUIT
WRITE !,"*No Principal Clinic"
+5 SET SC=0
FOR
SET SC=$ORDER(^SC(SC))
IF 'SC
QUIT
Begin DoDot:1
+6 IF '$$NPC
QUIT
IF '$$CK
QUIT
DO DAY
End DoDot:1
IF POP
QUIT
+7 QUIT
+8 ;
DAY ; -- loop visit days / clinic and print next appt
+1 SET SDAY=$$SD
FOR
SET SDAY=$ORDER(^SC(SC,"ST",SDAY))
IF 'SDAY
QUIT
IF $$NA
QUIT
+2 IF 'SDAY
WRITE ?26,$EXTRACT($PIECE(^SC(SC,0),U),1,30),?57,"none",!
Begin DoDot:1
+3 IF $Y>(IOSL-6)
IF IOST["C-"
Begin DoDot:2
+4 NEW DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET POP=1
End DoDot:2
IF POP
QUIT
DO HD
QUIT
End DoDot:1
QUIT
+5 SET X=$ORDER(^SC(SC,"ST",SDAY,0))
IF 'X
QUIT
+6 SET Y=$$FMTE^XLFDT(SDAY)
+7 WRITE ?26,$EXTRACT($PIECE(^SC(SC,0),U),1,30),?57,Y,?71,$JUSTIFY($$D(SDAY),2)," days",!
+8 IF $Y>(IOSL-6)
IF IOST["C-"
Begin DoDot:1
+9 NEW DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET POP=1
End DoDot:1
IF POP
QUIT
DO HD
+10 QUIT
+11 ;
PC ; -- principle clinic
+1 WRITE !,$EXTRACT($PIECE(^SC(PC,0),U),1,25)
QUIT
+2 ;
DEV ; -- device selection
+1 SET %ZIS="PQ"
DO ^%ZIS
KILL %ZIS
QUIT
+2 ;
HD ; -- heading
+1 WRITE @IOF,!!,?2,"Next Available Appointment by Principle Clinic"
+2 NEW %,%H,%I,X
DO NOW^%DTC
WRITE ?60,%I(1),"/",%I(2),"/",$EXTRACT(%I(3),2,3)
+3 WRITE " ",$EXTRACT($PIECE(%,".",2),1,2),":",$EXTRACT($PIECE(%,".",2),3,4),!!
+4 IF $GET(PC)
IF $ORDER(^SC("AIHSPC",PC,SC))
WRITE !,$EXTRACT($PIECE(^SC(PC,0),U),1,16)," ..cont."
+5 QUIT
+6 ;
Q ; -- cleanup
+1 IF IOST["C-"
IF '$GET(POP)
DO PRTOPT^ASDVAR
+2 DO ^%ZISC
DO HOME^%ZIS
QUIT
+3 ;
QUE ; -- queued output
+1 SET ZTRTN="EN^ASDPCNA"
SET ZTDESC="Principle Clinic Next Appointment"
+2 DO ^%ZTLOAD
QUIT
+3 ;
CK() ; -- active clinic? (yes=true)
+1 NEW X
+2 SET X=$GET(^SC(SC,"I"))
IF '$DATA(^SC(SC,"ST"))
QUIT 0
IF '$ORDER(^("ST",DT))
QUIT 0
+3 QUIT $SELECT($PIECE(^SC(SC,0),U,3)'="C":0,'X:1,(DT>(X-1))&('$PIECE(X,U,2)):0,1:1)
+4 ;
NA() ; -- next appointment
+1 NEW X,Y,Z,J
+2 SET Y=$ORDER(^SC(SC,"ST",SDAY,0))
IF 'Y
QUIT 0
+3 SET X="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
+4 SET Z=$EXTRACT(^SC(SC,"ST",SDAY,Y),6,$LENGTH(^SC(SC,"ST",SDAY,Y)))
+5 FOR J=1:1:$LENGTH(Z)
IF $EXTRACT(X,$FIND(X,"0"),$LENGTH(X))[$EXTRACT(Z,J)
SET J=999
+6 QUIT $SELECT(J=999:1,1:0)
+7 ;
NPC() ; -- principle clinic (none=false)
+1 QUIT $SELECT($PIECE($GET(^SC(SC,"SL")),U,5):0,1:1)
+2 ;
D(X1,X2,X) ; -- number of days
+1 SET X2=DT
DO ^%DTC
QUIT X
+2 ;
SD(X1,X2,X) ; -- start day
+1 SET X1=DT
SET X2=-1
DO C^%DTC
QUIT X
