- ASDWL ; IHS/ADC/PDW/ENM - WAITING LIST ; [ 03/25/1999 11:48 AM ]
- ;;5.0;IHS SCHEDULING;;MAR 25, 1999
- ;
- K ^TMP("ASDWL",$J)
- A ; -- driver
- NEW ASDC,ASDS
- D SC I Y<0 Q
- D SB I $D(DIRUT) Q
- D SD I POP D Q Q
- B
- I $D(IO("Q")) D QUE,Q Q
- EN ;EP; -- queued EP
- U IO
- D LF,HD,LT,Q Q
- ;
- ;
- SC ; -- select clinic
- K DIC S DIC="^ASDWL(",DIC(0)="AEQ" D ^DIC S ASDC=+Y K DIC Q
- ;
- SB ; -- sort by
- K DIR S DIR("A")="Select SORT for Report",DIR(0)="N^1:3"
- S DIR("A",1)="Sort by (1) Provider to be Seen"
- S DIR("A",2)=" (2) Date Added to List"
- S DIR("A",3)=" (3) Recall Date"
- W ! D ^DIR S ASDS=Y K DIR Q
- ;
- SD ; -- select device
- S %ZIS="PQ" D ^%ZIS Q
- ;
- QUE ; -- queued output
- S ZTRTN="EN^ASDWL",ZTDESC="Waiting List"
- S ZTSAVE("ASDC")="",ZTSAVE("ASDS")=""
- D ^%ZTLOAD Q
- ;
- LF ; -- loop waiting list
- NEW I,N
- S I=0 F S I=$O(^ASDWL(ASDC,1,I)) Q:'I D
- . S N=$G(^ASDWL(ASDC,1,I,0)) Q:'N
- . S ^TMP("ASDWL",$J,ASDC,$$SORT(ASDS,N),+N,I)=N
- Q
- ;
- LT ; -- loop temp
- NEW ASDI,DFN,ASDJ
- S ASDQ="",ASDI=0
- F S ASDI=$O(^TMP("ASDWL",$J,ASDC,ASDI)) Q:ASDI=""!(ASDQ=U) D
- . S DFN=0
- . F S DFN=$O(^TMP("ASDWL",$J,ASDC,ASDI,DFN)) Q:'DFN!(ASDQ=U) D
- .. S ASDJ=0
- .. F S ASDJ=$O(^TMP("ASDWL",$J,ASDC,ASDI,DFN,ASDJ)) Q:'ASDJ!(ASDQ=U) D
- ... I $Y>(IOSL-4) D NWPG Q:ASDQ=U
- ... S N=^TMP("ASDWL",$J,ASDC,ASDI,DFN,ASDJ)
- ... W !!,$E($P(^DPT(DFN,0),U),1,20),?22,$$HRN^ASDUT(DFN)
- ... W ?32,$$AGE(DFN),?40,$$PHONE(DFN)
- ... W ?56,$$DT($P(N,U,3)),?66,$$DT($P(N,U,6))
- ... W ?76,$$PRV($P(N,U,7))
- ... W:$P(N,U,4)]"" !?3,"(",$E($P(N,U,4),1,75),")"
- Q
- ;
- HD ; -- heading
- I IOST["C-" W @IOF
- W !?12,$$CONF^ASDUT
- W !?2,"WAITING LIST for ",$P($G(^SC(+ASDC,0)),U)
- S Y=DT X ^DD("DD") W ?60,Y
- W !!,"Patient",?22,"HRCN",?33,"Age",?40,"Phone",?56,"Dt Added"
- W ?66,"Recall",?76,"Prov"
- W !,$$REPEAT^XLFSTR("=",80) Q
- ;
- Q ; -- cleanup
- D ^%ZISC K ^TMP("ASDWL",$J) K DIR,POP,ASDQ Q
- ;
- NWPG ; -- new page
- I IOST'["C-" W @IOF D HD Q
- K DIR S DIR(0)="E" D ^DIR S ASDQ=X
- I ASDQ="" D HD
- Q
- ;
- DT(Y) ; -- date entered
- Q $S(Y="":"",1:$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3))
- ;
- PRV(X) ; -- returns provider name
- Q $P($G(^VA(200,+X,0)),U,2)
- ;
- SORT(S,N) ; -- returns sort subscript
- I S=1 Q $S($P(N,U,7)]"":$$PRV($P(N,U,7)),1:" ")
- I S=2 Q $S($P(N,U,3)]"":$P(N,U,3),1:" ")
- I S=3 Q $S($P(N,U,6)]"":$P(N,U,6),1:" ")
- Q " "
- ;
- AGE(DFN) ; -- returns printable age
- Q $$VAL^XBDIQ1(9000001,DFN,1102.98)
- ;
- PHONE(DFN) ; -- returns patient's phone #
- Q $E($$VAL^XBDIQ1(2,DFN,.131),1,15)
- ASDWL ; IHS/ADC/PDW/ENM - WAITING LIST ; [ 03/25/1999 11:48 AM ]
- +1 ;;5.0;IHS SCHEDULING;;MAR 25, 1999
- +2 ;
- +3 KILL ^TMP("ASDWL",$JOB)
- A ; -- driver
- +1 NEW ASDC,ASDS
- +2 DO SC
- IF Y<0
- QUIT
- +3 DO SB
- IF $DATA(DIRUT)
- QUIT
- +4 DO SD
- IF POP
- DO Q
- QUIT
- +5 BREAK
- +6 IF $DATA(IO("Q"))
- DO QUE
- DO Q
- QUIT
- EN ;EP; -- queued EP
- +1 USE IO
- +2 DO LF
- DO HD
- DO LT
- DO Q
- QUIT
- +3 ;
- +4 ;
- SC ; -- select clinic
- +1 KILL DIC
- SET DIC="^ASDWL("
- SET DIC(0)="AEQ"
- DO ^DIC
- SET ASDC=+Y
- KILL DIC
- QUIT
- +2 ;
- SB ; -- sort by
- +1 KILL DIR
- SET DIR("A")="Select SORT for Report"
- SET DIR(0)="N^1:3"
- +2 SET DIR("A",1)="Sort by (1) Provider to be Seen"
- +3 SET DIR("A",2)=" (2) Date Added to List"
- +4 SET DIR("A",3)=" (3) Recall Date"
- +5 WRITE !
- DO ^DIR
- SET ASDS=Y
- KILL DIR
- QUIT
- +6 ;
- SD ; -- select device
- +1 SET %ZIS="PQ"
- DO ^%ZIS
- QUIT
- +2 ;
- QUE ; -- queued output
- +1 SET ZTRTN="EN^ASDWL"
- SET ZTDESC="Waiting List"
- +2 SET ZTSAVE("ASDC")=""
- SET ZTSAVE("ASDS")=""
- +3 DO ^%ZTLOAD
- QUIT
- +4 ;
- LF ; -- loop waiting list
- +1 NEW I,N
- +2 SET I=0
- FOR
- SET I=$ORDER(^ASDWL(ASDC,1,I))
- IF 'I
- QUIT
- Begin DoDot:1
- +3 SET N=$GET(^ASDWL(ASDC,1,I,0))
- IF 'N
- QUIT
- +4 SET ^TMP("ASDWL",$JOB,ASDC,$$SORT(ASDS,N),+N,I)=N
- End DoDot:1
- +5 QUIT
- +6 ;
- LT ; -- loop temp
- +1 NEW ASDI,DFN,ASDJ
- +2 SET ASDQ=""
- SET ASDI=0
- +3 FOR
- SET ASDI=$ORDER(^TMP("ASDWL",$JOB,ASDC,ASDI))
- IF ASDI=""!(ASDQ=U)
- QUIT
- Begin DoDot:1
- +4 SET DFN=0
- +5 FOR
- SET DFN=$ORDER(^TMP("ASDWL",$JOB,ASDC,ASDI,DFN))
- IF 'DFN!(ASDQ=U)
- QUIT
- Begin DoDot:2
- +6 SET ASDJ=0
- +7 FOR
- SET ASDJ=$ORDER(^TMP("ASDWL",$JOB,ASDC,ASDI,DFN,ASDJ))
- IF 'ASDJ!(ASDQ=U)
- QUIT
- Begin DoDot:3
- +8 IF $Y>(IOSL-4)
- DO NWPG
- IF ASDQ=U
- QUIT
- +9 SET N=^TMP("ASDWL",$JOB,ASDC,ASDI,DFN,ASDJ)
- +10 WRITE !!,$EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?22,$$HRN^ASDUT(DFN)
- +11 WRITE ?32,$$AGE(DFN),?40,$$PHONE(DFN)
- +12 WRITE ?56,$$DT($PIECE(N,U,3)),?66,$$DT($PIECE(N,U,6))
- +13 WRITE ?76,$$PRV($PIECE(N,U,7))
- +14 IF $PIECE(N,U,4)]""
- WRITE !?3,"(",$EXTRACT($PIECE(N,U,4),1,75),")"
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +15 QUIT
- +16 ;
- HD ; -- heading
- +1 IF IOST["C-"
- WRITE @IOF
- +2 WRITE !?12,$$CONF^ASDUT
- +3 WRITE !?2,"WAITING LIST for ",$PIECE($GET(^SC(+ASDC,0)),U)
- +4 SET Y=DT
- XECUTE ^DD("DD")
- WRITE ?60,Y
- +5 WRITE !!,"Patient",?22,"HRCN",?33,"Age",?40,"Phone",?56,"Dt Added"
- +6 WRITE ?66,"Recall",?76,"Prov"
- +7 WRITE !,$$REPEAT^XLFSTR("=",80)
- QUIT
- +8 ;
- Q ; -- cleanup
- +1 DO ^%ZISC
- KILL ^TMP("ASDWL",$JOB)
- KILL DIR,POP,ASDQ
- QUIT
- +2 ;
- NWPG ; -- new page
- +1 IF IOST'["C-"
- WRITE @IOF
- DO HD
- QUIT
- +2 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- SET ASDQ=X
- +3 IF ASDQ=""
- DO HD
- +4 QUIT
- +5 ;
- DT(Y) ; -- date entered
- +1 QUIT $SELECT(Y="":"",1:$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3))
- +2 ;
- PRV(X) ; -- returns provider name
- +1 QUIT $PIECE($GET(^VA(200,+X,0)),U,2)
- +2 ;
- SORT(S,N) ; -- returns sort subscript
- +1 IF S=1
- QUIT $SELECT($PIECE(N,U,7)]"":$$PRV($PIECE(N,U,7)),1:" ")
- +2 IF S=2
- QUIT $SELECT($PIECE(N,U,3)]"":$PIECE(N,U,3),1:" ")
- +3 IF S=3
- QUIT $SELECT($PIECE(N,U,6)]"":$PIECE(N,U,6),1:" ")
- +4 QUIT " "
- +5 ;
- AGE(DFN) ; -- returns printable age
- +1 QUIT $$VAL^XBDIQ1(9000001,DFN,1102.98)
- +2 ;
- PHONE(DFN) ; -- returns patient's phone #
- +1 QUIT $EXTRACT($$VAL^XBDIQ1(2,DFN,.131),1,15)
