- QAOSPNAM ;HISC/DAD-ATTENDING & RESIDENT/PROVIDER REPORT ;6/17/93 11:13
- ;;3.0;Occurrence Screen;;09/14/1993
- K DIR S DIR(0)="SOM^C:Code;N:Name",DIR("A")="Sort report by"
- S DIR("?",1)="",DIR("?")=" Enter the desired sorting method."
- S DIR("B")="Name"
- 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^QAOSPNAM",ZTSAVE("QAOSSORT")=""
- . S ZTDESC="Attending & resident/provider report"
- . D ^%ZTLOAD
- . Q
- ENTSK ;
- S PAGE=1,%DT="",X="T" D ^%DT X ^DD("DD") S TODAY=Y
- K ^TMP($J,"QAOSPNAM"),UNDL S $P(UNDL,"-",80)="-"
- F QAOSD0=0:0 S QAOSD0=$O(^QA(741,QAOSD0)) Q:QAOSD0'>0 D
- . S QAOSZERO=$G(^QA(741,QAOSD0,0)) Q:QAOSZERO=""
- . F QA=9,10 D
- .. S QAOSCODE=+$P(QAOSZERO,"^",QA) Q:QAOSCODE'>0
- .. S QAOSNAME=$P($G(^VA(200,QAOSCODE,0)),"^")
- .. S:QAOSNAME="" QAOSNAME=QAOSCODE
- .. I QAOSSORT="N" D SET(QAOSNAME,QAOSCODE,QA-7)
- .. E D SET(QAOSCODE,QAOSNAME,QA-7)
- .. Q
- . Q
- U IO D HEAD
- I '$D(^TMP($J,"QAOSPNAM")) W !!,"NO DATA FOUND FOR THIS REPORT" G EXIT
- S QAOSSUB="",QAOSQUIT=0
- F S QAOSSUB=$O(^TMP($J,"QAOSPNAM",QAOSSUB)) Q:QAOSSUB=""!QAOSQUIT D
- . S QAOSDATA=^TMP($J,"QAOSPNAM",QAOSSUB)
- . I QAOSSORT="N" S QAOSNAME=QAOSSUB,QAOSCODE=$P(QAOSDATA,"^")
- . E S QAOSNAME=$P(QAOSDATA,"^"),QAOSCODE=QAOSSUB
- . W !,QAOSNAME,?35,$J(QAOSCODE,9)
- . W ?53,$P(QAOSDATA,"^",2),?71,$P(QAOSDATA,"^",3)
- . I $Y>(IOSL-6) D:$E(IOST)="C" PAUSE Q:QAOSQUIT D HEAD
- . Q
- EXIT ;
- W ! D ^%ZISC
- K %DT,%ZIS,DIR,DIRUT,DTOUT,DUOUT,PAGE,POP,QA,QAOSD0,QAOSDATA,QAOSCODE
- K QAOSNAME,QAOSQUIT,QAOSSUB,QAOSZERO,TODAY,UNDL,X,Y,ZTRTN,ZTDESC
- K QAOSSORT,^TMP($J,"QAOSPNAM")
- S:$D(ZTQUEUED) ZTREQ="@"
- Q
- SET(SUBSCRPT,DATA,PIECE) ;
- S $P(^TMP($J,"QAOSPNAM",SUBSCRPT),"^")=DATA
- S $P(^TMP($J,"QAOSPNAM",SUBSCRPT),"^",PIECE)="X"
- Q
- PAUSE ;
- K DIR S DIR(0)="E" D ^DIR K DIR S QAOSQUIT=$S(Y'>0:1,1:0)
- Q
- HEAD ;
- W:(PAGE>1)!($E(IOST)="C") @IOF
- W !!?29,"PRACTITIONER CODE LIST",?68,TODAY,!?68,"PAGE: ",PAGE
- S PAGE=PAGE+1 D EN6^QAQAUTL
- W !,"PRACTITIONER",?35,"CODE NUMBER",?49,"ATTENDING",?63,"RESIDENT/PROVIDER"
- W !,UNDL,!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAOSPNAM 2130 printed Apr 23, 2025@18:36:20 Page 2
- QAOSPNAM ;HISC/DAD-ATTENDING & RESIDENT/PROVIDER REPORT ;6/17/93 11:13
- +1 ;;3.0;Occurrence Screen;;09/14/1993
- +2 KILL DIR
- SET DIR(0)="SOM^C:Code;N:Name"
- SET DIR("A")="Sort report by"
- +3 SET DIR("?",1)=""
- SET DIR("?")=" Enter the desired sorting method."
- +4 SET DIR("B")="Name"
- +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^QAOSPNAM"
- SET ZTSAVE("QAOSSORT")=""
- +9 SET ZTDESC="Attending & resident/provider report"
- +10 DO ^%ZTLOAD
- +11 QUIT
- End DoDot:1
- GOTO EXIT
- ENTSK ;
- +1 SET PAGE=1
- SET %DT=""
- SET X="T"
- DO ^%DT
- XECUTE ^DD("DD")
- SET TODAY=Y
- +2 KILL ^TMP($JOB,"QAOSPNAM"),UNDL
- SET $PIECE(UNDL,"-",80)="-"
- +3 FOR QAOSD0=0:0
- SET QAOSD0=$ORDER(^QA(741,QAOSD0))
- if QAOSD0'>0
- QUIT
- Begin DoDot:1
- +4 SET QAOSZERO=$GET(^QA(741,QAOSD0,0))
- if QAOSZERO=""
- QUIT
- +5 FOR QA=9,10
- Begin DoDot:2
- +6 SET QAOSCODE=+$PIECE(QAOSZERO,"^",QA)
- if QAOSCODE'>0
- QUIT
- +7 SET QAOSNAME=$PIECE($GET(^VA(200,QAOSCODE,0)),"^")
- +8 if QAOSNAME=""
- SET QAOSNAME=QAOSCODE
- +9 IF QAOSSORT="N"
- DO SET(QAOSNAME,QAOSCODE,QA-7)
- +10 IF '$TEST
- DO SET(QAOSCODE,QAOSNAME,QA-7)
- +11 QUIT
- End DoDot:2
- +12 QUIT
- End DoDot:1
- +13 USE IO
- DO HEAD
- +14 IF '$DATA(^TMP($JOB,"QAOSPNAM"))
- WRITE !!,"NO DATA FOUND FOR THIS REPORT"
- GOTO EXIT
- +15 SET QAOSSUB=""
- SET QAOSQUIT=0
- +16 FOR
- SET QAOSSUB=$ORDER(^TMP($JOB,"QAOSPNAM",QAOSSUB))
- if QAOSSUB=""!QAOSQUIT
- QUIT
- Begin DoDot:1
- +17 SET QAOSDATA=^TMP($JOB,"QAOSPNAM",QAOSSUB)
- +18 IF QAOSSORT="N"
- SET QAOSNAME=QAOSSUB
- SET QAOSCODE=$PIECE(QAOSDATA,"^")
- +19 IF '$TEST
- SET QAOSNAME=$PIECE(QAOSDATA,"^")
- SET QAOSCODE=QAOSSUB
- +20 WRITE !,QAOSNAME,?35,$JUSTIFY(QAOSCODE,9)
- +21 WRITE ?53,$PIECE(QAOSDATA,"^",2),?71,$PIECE(QAOSDATA,"^",3)
- +22 IF $Y>(IOSL-6)
- if $EXTRACT(IOST)="C"
- DO PAUSE
- if QAOSQUIT
- QUIT
- DO HEAD
- +23 QUIT
- End DoDot:1
- EXIT ;
- +1 WRITE !
- DO ^%ZISC
- +2 KILL %DT,%ZIS,DIR,DIRUT,DTOUT,DUOUT,PAGE,POP,QA,QAOSD0,QAOSDATA,QAOSCODE
- +3 KILL QAOSNAME,QAOSQUIT,QAOSSUB,QAOSZERO,TODAY,UNDL,X,Y,ZTRTN,ZTDESC
- +4 KILL QAOSSORT,^TMP($JOB,"QAOSPNAM")
- +5 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +6 QUIT
- SET(SUBSCRPT,DATA,PIECE) ;
- +1 SET $PIECE(^TMP($JOB,"QAOSPNAM",SUBSCRPT),"^")=DATA
- +2 SET $PIECE(^TMP($JOB,"QAOSPNAM",SUBSCRPT),"^",PIECE)="X"
- +3 QUIT
- PAUSE ;
- +1 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- SET QAOSQUIT=$SELECT(Y'>0:1,1:0)
- +2 QUIT
- HEAD ;
- +1 if (PAGE>1)!($EXTRACT(IOST)="C")
- WRITE @IOF
- +2 WRITE !!?29,"PRACTITIONER CODE LIST",?68,TODAY,!?68,"PAGE: ",PAGE
- +3 SET PAGE=PAGE+1
- DO EN6^QAQAUTL
- +4 WRITE !,"PRACTITIONER",?35,"CODE NUMBER",?49,"ATTENDING",?63,"RESIDENT/PROVIDER"
- +5 WRITE !,UNDL,!
- +6 QUIT
