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)
