- 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
