QAOSPTX0 ;HISC/DAD-TREATING SPECIALTY CARE TYPES REPORT ;9/14/93 15:48
;;3.0;Occurrence Screen;;09/14/1993
K DIR S DIR(0)="SOM^C:Care type;T:Treating specialty;"
S DIR("A")="Sort by",DIR("B")="Care type"
S DIR("?",1)="",DIR("?")=" Enter the desired sorting method."
D ^DIR G:$D(DIRUT) EXIT S QAOSSORT=Y
K %ZIS,IOP S %ZIS="QM" W ! D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EXIT
. S ZTRTN="ENTSK^QAOSPTX0",ZTSAVE("QAOSSORT")=""
. S ZTDESC="Treating specialty care types report"
. D ^%ZTLOAD
. Q
ENTSK ;
K ^TMP($J,"QAOSPTX0") S QAOSTEXT=""
F S QAOSTEXT=$O(^DIC(45.7,"B",QAOSTEXT)) Q:QAOSTEXT="" D
. F QAOSD0=0:0 S QAOSD0=$O(^DIC(45.7,"B",QAOSTEXT,QAOSD0)) Q:QAOSD0'>0 D
.. S QAOSTXSP=$P($G(^DIC(45.7,QAOSD0,0)),"^") Q:QAOSTXSP=""
.. S QAOSS0=+$O(^QA(741.9,"B",QAOSD0,0))
.. S QAOSTYPE=$P($G(^QA(741.9,QAOSS0,0)),"^",2)
.. I QAOSTYPE="" S QAOSTYPE="?"
.. S QAOSTYPE(0)=$P(^DD(741.9,1,0),"^",3)_"?: *** NOT SPECIFIED ***;"
.. S QAOSTYPE=$P($P(QAOSTYPE(0),QAOSTYPE_":",2),";")
.. I QAOSSORT="C" S ^TMP($J,"QAOSPTX0",QAOSTYPE,QAOSTXSP)=""
.. E S ^TMP($J,"QAOSPTX0",QAOSTXSP,QAOSTYPE)=""
.. Q
. Q
PRINT ;
U IO
K QAOSUNDL S QAOSQUIT=0,QAOSPAGE=1,$P(QAOSUNDL,"-",81)=""
S Y=DT X ^DD("DD") S QAOTODAY=Y,QAOSTXT1="" D HEAD
F S QAOSTXT1=$O(^TMP($J,"QAOSPTX0",QAOSTXT1)) Q:QAOSTXT1=""!QAOSQUIT D
. S QAOSTXT2=""
. F S QAOSTXT2=$O(^TMP($J,"QAOSPTX0",QAOSTXT1,QAOSTXT2)) Q:QAOSTXT2=""!QAOSQUIT D
.. I QAOSSORT="C" W !,QAOSTXT2,?40,$E(QAOSTXT1,$E(QAOSTXT1)=" "+1,999)
.. E W !,QAOSTXT1,?40,$E(QAOSTXT2,$E(QAOSTXT2)=" "+1,999)
.. I $Y>(IOSL-6) D
... I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S QAOSQUIT=$S(Y'>0:1,1:0)
... Q:QAOSQUIT
... D HEAD
... Q
.. Q
. Q
EXIT ;
D ^%ZISC
K %ZIS,DIR,DIRUT,DTOUT,DUOUT,POP,QAOSD0,QAOSPAGE,QAOSQUIT,QAOSS0
K QAOSSORT,QAOSTEXT,QAOSTXSP,QAOSTXT1,QAOSTXT2,QAOSTYPE,QAOSUNDL
K QAOTODAY,Y,ZTDESC,ZTDTH,ZTRTN,^TMP($J,"QAOSPTX0")
Q
HEAD ;
W:($E(IOST)="C")!(QAOSPAGE>1) @IOF
W !!?25,"TREATING SPECIALTY CARE TYPES"
W ?68,QAOTODAY,!?68,"PAGE: ",QAOSPAGE S QAOSPAGE=QAOSPAGE+1
W !,"TREATING SPECIALTY",?40,"CARE TYPE"
W !,QAOSUNDL,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPTX0 2155 printed Dec 13, 2024@02:22:06 Page 2
QAOSPTX0 ;HISC/DAD-TREATING SPECIALTY CARE TYPES REPORT ;9/14/93 15:48
+1 ;;3.0;Occurrence Screen;;09/14/1993
+2 KILL DIR
SET DIR(0)="SOM^C:Care type;T:Treating specialty;"
+3 SET DIR("A")="Sort by"
SET DIR("B")="Care type"
+4 SET DIR("?",1)=""
SET DIR("?")=" Enter the desired sorting method."
+5 DO ^DIR
if $DATA(DIRUT)
GOTO EXIT
SET QAOSSORT=Y
+6 KILL %ZIS,IOP
SET %ZIS="QM"
WRITE !
DO ^%ZIS
if POP
GOTO EXIT
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 SET ZTRTN="ENTSK^QAOSPTX0"
SET ZTSAVE("QAOSSORT")=""
+9 SET ZTDESC="Treating specialty care types report"
+10 DO ^%ZTLOAD
+11 QUIT
End DoDot:1
GOTO EXIT
ENTSK ;
+1 KILL ^TMP($JOB,"QAOSPTX0")
SET QAOSTEXT=""
+2 FOR
SET QAOSTEXT=$ORDER(^DIC(45.7,"B",QAOSTEXT))
if QAOSTEXT=""
QUIT
Begin DoDot:1
+3 FOR QAOSD0=0:0
SET QAOSD0=$ORDER(^DIC(45.7,"B",QAOSTEXT,QAOSD0))
if QAOSD0'>0
QUIT
Begin DoDot:2
+4 SET QAOSTXSP=$PIECE($GET(^DIC(45.7,QAOSD0,0)),"^")
if QAOSTXSP=""
QUIT
+5 SET QAOSS0=+$ORDER(^QA(741.9,"B",QAOSD0,0))
+6 SET QAOSTYPE=$PIECE($GET(^QA(741.9,QAOSS0,0)),"^",2)
+7 IF QAOSTYPE=""
SET QAOSTYPE="?"
+8 SET QAOSTYPE(0)=$PIECE(^DD(741.9,1,0),"^",3)_"?: *** NOT SPECIFIED ***;"
+9 SET QAOSTYPE=$PIECE($PIECE(QAOSTYPE(0),QAOSTYPE_":",2),";")
+10 IF QAOSSORT="C"
SET ^TMP($JOB,"QAOSPTX0",QAOSTYPE,QAOSTXSP)=""
+11 IF '$TEST
SET ^TMP($JOB,"QAOSPTX0",QAOSTXSP,QAOSTYPE)=""
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
PRINT ;
+1 USE IO
+2 KILL QAOSUNDL
SET QAOSQUIT=0
SET QAOSPAGE=1
SET $PIECE(QAOSUNDL,"-",81)=""
+3 SET Y=DT
XECUTE ^DD("DD")
SET QAOTODAY=Y
SET QAOSTXT1=""
DO HEAD
+4 FOR
SET QAOSTXT1=$ORDER(^TMP($JOB,"QAOSPTX0",QAOSTXT1))
if QAOSTXT1=""!QAOSQUIT
QUIT
Begin DoDot:1
+5 SET QAOSTXT2=""
+6 FOR
SET QAOSTXT2=$ORDER(^TMP($JOB,"QAOSPTX0",QAOSTXT1,QAOSTXT2))
if QAOSTXT2=""!QAOSQUIT
QUIT
Begin DoDot:2
+7 IF QAOSSORT="C"
WRITE !,QAOSTXT2,?40,$EXTRACT(QAOSTXT1,$EXTRACT(QAOSTXT1)=" "+1,999)
+8 IF '$TEST
WRITE !,QAOSTXT1,?40,$EXTRACT(QAOSTXT2,$EXTRACT(QAOSTXT2)=" "+1,999)
+9 IF $Y>(IOSL-6)
Begin DoDot:3
+10 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
+11 if QAOSQUIT
QUIT
+12 DO HEAD
+13 QUIT
End DoDot:3
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
EXIT ;
+1 DO ^%ZISC
+2 KILL %ZIS,DIR,DIRUT,DTOUT,DUOUT,POP,QAOSD0,QAOSPAGE,QAOSQUIT,QAOSS0
+3 KILL QAOSSORT,QAOSTEXT,QAOSTXSP,QAOSTXT1,QAOSTXT2,QAOSTYPE,QAOSUNDL
+4 KILL QAOTODAY,Y,ZTDESC,ZTDTH,ZTRTN,^TMP($JOB,"QAOSPTX0")
+5 QUIT
HEAD ;
+1 if ($EXTRACT(IOST)="C")!(QAOSPAGE>1)
WRITE @IOF
+2 WRITE !!?25,"TREATING SPECIALTY CARE TYPES"
+3 WRITE ?68,QAOTODAY,!?68,"PAGE: ",QAOSPAGE
SET QAOSPAGE=QAOSPAGE+1
+4 WRITE !,"TREATING SPECIALTY",?40,"CARE TYPE"
+5 WRITE !,QAOSUNDL,!
+6 QUIT
