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 Dec 13, 2024@02:21:46 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
