- 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 Feb 18, 2025@23:48:33 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
