DENTAR14 ;ISC2/SAW,HAG-REVIEW/RELEASE TREATMENT DATA REPORT - INDIVIDUAL SITTINGS ; 10/27/88 10:15 AM ;
;VERSION 1.2
S %ZIS="MQ" K IO("Q") D ^%ZIS G EXIT1:IO=""
I $D(IO("Q")) S ZTRTN="QUE^DENTAR14",ZTSAVE("DENT*")="",ZTSAVE("DT")="",ZTSAVE("U")="",ZTSAVE("Z3")="",ZTSAVE("Z5")="",ZTSAVE("H*")="" D ^%ZTLOAD K ZTSK,ZTRTN,ZTSAVE G EXIT1
QUE U IO S (DENTC(1),DENTC)=0,DENTSD=DENTSD-.0001,Q=1,DT1=$E(DT,1,5)_"08" D RPT G NONE:'DENTC D:Z5'=U HOLD S:Z5=U DENTF1=1 G EXIT
RPT F I=0:1 S DENTSD=$O(^DENT(221,"A",Z3,DENTSD)) Q:DENTSD>DENTED!(DENTSD="")!(DT<DT1&($E(DENTSD,1,5)=$E(DT,1,5))) D RPT1
Q
RPT1 D:'I HDR^DENTAR16 S DENT="" F J=0:0 S DENT=$O(^DENT(221,"A",Z3,DENTSD,DENT)) Q:DENT="" I $D(^DENT(221,DENT,0)) S X=^(0) D HDR1 Q:Z5=U D P1 Q:Z5=U
Q
P1 I $D(^DENT(221,DENT,.1)),$P(^(.1),U,1) Q
S DENTC=DENTC+1 D CHK^DENTAR15 Q:DENTF S:'$D(DENTF1) ^UTILITY($J,"DENTP",DENT)=DENTSD
I '$D(DENTF1),DENTC=181 S:IO=IO(0) ^UTILITY($J,"DENTV",Q,DENTC-1,0)=^UTILITY($J,"DENTV",Q,DENTC-1,0)_"$" S Q=Q+1,DENTC(1)=DENTC(1)+180,DENTC=1
S DENTCAT=$P(X,U,19),DENTCAT="00"_DENTCAT,DENTCAT=$E(DENTCAT,$L(DENTCAT)-1,$L(DENTCAT))
I IO=IO(0),'$D(DENTF1),'$D(DENTV) D DENTV
I $P(X,U,27) S K=$S($P(X,U,27)=1:35,1:37) W ?46,$E($P(^DIC(220.3,K,0),U,1),1,30),?79,1,! D:IOSL-($Y#IOSL)<4 HOLD1 Q:Z5=U S X(1)=$P(X,U,27) D SPOT Q
I $P(X,U,44) W ?46,$E($P(^DIC(220.3,36,0),U,1),1,30),?79,1,! W:$P(X,U,45) ?46,$E($P(^DIC(220.3,38,0),U,1),1,30),?79,$P(X,U,45),! D:IOSL-($Y#IOSL)<4 HOLD1 Q:Z5=U S X(1)=$P(X,U,44) D SPOT Q
I $P(X,U,41) W ?46,$E($P(^DIC(220.3,$P(X,U,41),0),U,1),1,30),?79,1,! D:IOSL-($Y#IOSL)<4 HOLD1 Q:Z5=U S X(2)=0_$P(X,U,41) I IO=IO(0),'$D(DENTF1) S DENTV=DENTV_X(2)_"01"
I $P(X,U,8) W ?46,"ADMINISTRATIVE PROCEDURE",?79,1,! D:IOSL-($Y#IOSL)<4 HOLD1 Q:Z5=U I IO=IO(0),'$D(DENTF1) S DENTV=DENTV_3501
I $P(X,U,7)'="" S X(2)=$S($P(X,U,7)="S":"04",1:"05") W ?46,$E($P(^DIC(220.3,+X(2),0),U,1),1,30),?79,1,! D:IOSL-($Y#IOSL)<4 HOLD1 Q:Z5=U I IO=IO(0),'$D(DENTF1) S DENTV=DENTV_X(2)_"01"
F K=9,11:1:18,20,22:1:26,28:1:38,42:1:43 I $P(X,U,K) D W Q:Z5=U
I IO=IO(0),'$D(DENTF1) S $P(X1," ",51)=" ",DENTV=DENTV_X1,^UTILITY($J,"DENTV",Q,DENTC,0)=$E(DENTV,1,80) K X1,DENTV
Q
W W ?46,$E($P(^DIC(220.3,+$P($T(S),";",K),0),U,1),1,30),?77,$J($P(X,U,K),3),! D:IOSL-($Y#IOSL)<4 HOLD1 Q:Z5=U
I IO=IO(0),'$D(DENTF1) S X(2)=$P($T(S),";",K),X(3)=$P(X,U,K),X(3)=0_X(3),X(3)=$E(X(3),($L(X(3))-1),$L(X(3))),DENTV=DENTV_X(2)_X(3)
Q
SPOT I IO=IO(0),'$D(DENTF1) S DENTDAT=$P(X,U,1),DENTDAT=$E(DENTDAT,4,5)_$E(DENTDAT,6,7)_$E(DENTDAT,2,3)
Q
HDR1 I IOSL-($Y#IOSL)<4 D HOLD Q:Z5=U D HDR^DENTAR16
S Y=$P(X,U,1) X ^DD("DD") W !,Y,?19,$P(X,U,10),?25,$P(X,U,2),?36,$J($P(X,U,19),2),?41 W:$P(X,U,19)<9 $J($P(X,U,6),2) Q
DENTV S X(1)=$P(X,U,6),X(1)=$S(X(1)="":" ",1:0_X(1)),X(1)=$E(X(1),$L(X(1))-1,$L(X(1))),DENTDAT=$P(X,U,1),DENTDAT=$E(DENTDAT,4,5)_$E(DENTDAT,6,7)_$E(DENTDAT,2,3)
S DENTV=1_DENTSTA_$P(X,U,10)_$E($P(X,U,2),1,9)_DENTCAT_X(1)_DENTDAT Q
HOLD Q:$D(ZTSK)!(IO'=IO(0))!(Z5=U) S Z5="" R !,"Press return to continue, uparrow (^) to exit: ",Z5:DTIME Q
HOLD1 D HOLD D:Z5'=U HDR^DENTAR16 Q
NONE S DENTF1=1 W !,"There is no treatment data for review/release for the time frame you specified",*7 G EXIT1
EXIT G EXIT1:Z5=U I $D(DENTF1) W @IOF,*7 D ERR^DENTAR16 S H="" F I=1:1 Q:Z5=U S H=$O(^UTILITY($J,"DENTERR",H)) Q:H="" F J=1:1:5 D:IOSL-($Y#IOSL)<4 HOLD Q:Z5=U W:$D(^UTILITY($J,"DENTERR",H,J)) !,^(J)
D:'$D(DENTF1) COMP^DENTAR16 W ! D:$D(DENTF1)&(Z5'=U) HOLD
EXIT1 X ^%ZIS("C") K DENT,DENTCAT,DENTDAT,DENTED,DENTF,DENTSD,H,H1,H2,H3,I,J,K,X D:$D(ZTSK) EXIT1^DENTAR1 Q
S ;;;04;05;;;;08;;09;15;16;33;10;20;21;22;;23;;11;12;13;14;17;;24;25;26;27;28;29;30;31;18;19;32;;;;34;06
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDENTAR14 3695 printed Dec 13, 2024@01:45:58 Page 2
DENTAR14 ;ISC2/SAW,HAG-REVIEW/RELEASE TREATMENT DATA REPORT - INDIVIDUAL SITTINGS ; 10/27/88 10:15 AM ;
+1 ;VERSION 1.2
+2 SET %ZIS="MQ"
KILL IO("Q")
DO ^%ZIS
if IO=""
GOTO EXIT1
+3 IF $DATA(IO("Q"))
SET ZTRTN="QUE^DENTAR14"
SET ZTSAVE("DENT*")=""
SET ZTSAVE("DT")=""
SET ZTSAVE("U")=""
SET ZTSAVE("Z3")=""
SET ZTSAVE("Z5")=""
SET ZTSAVE("H*")=""
DO ^%ZTLOAD
KILL ZTSK,ZTRTN,ZTSAVE
GOTO EXIT1
QUE USE IO
SET (DENTC(1),DENTC)=0
SET DENTSD=DENTSD-.0001
SET Q=1
SET DT1=$EXTRACT(DT,1,5)_"08"
DO RPT
if 'DENTC
GOTO NONE
if Z5'=U
DO HOLD
if Z5=U
SET DENTF1=1
GOTO EXIT
RPT FOR I=0:1
SET DENTSD=$ORDER(^DENT(221,"A",Z3,DENTSD))
if DENTSD>DENTED!(DENTSD="")!(DT<DT1&($EXTRACT(DENTSD,1,5)=$EXTRACT(DT,1,5)))
QUIT
DO RPT1
+1 QUIT
RPT1 if 'I
DO HDR^DENTAR16
SET DENT=""
FOR J=0:0
SET DENT=$ORDER(^DENT(221,"A",Z3,DENTSD,DENT))
if DENT=""
QUIT
IF $DATA(^DENT(221,DENT,0))
SET X=^(0)
DO HDR1
if Z5=U
QUIT
DO P1
if Z5=U
QUIT
+1 QUIT
P1 IF $DATA(^DENT(221,DENT,.1))
IF $PIECE(^(.1),U,1)
QUIT
+1 SET DENTC=DENTC+1
DO CHK^DENTAR15
if DENTF
QUIT
if '$DATA(DENTF1)
SET ^UTILITY($JOB,"DENTP",DENT)=DENTSD
+2 IF '$DATA(DENTF1)
IF DENTC=181
if IO=IO(0)
SET ^UTILITY($JOB,"DENTV",Q,DENTC-1,0)=^UTILITY($JOB,"DENTV",Q,DENTC-1,0)_"$"
SET Q=Q+1
SET DENTC(1)=DENTC(1)+180
SET DENTC=1
+3 SET DENTCAT=$PIECE(X,U,19)
SET DENTCAT="00"_DENTCAT
SET DENTCAT=$EXTRACT(DENTCAT,$LENGTH(DENTCAT)-1,$LENGTH(DENTCAT))
+4 IF IO=IO(0)
IF '$DATA(DENTF1)
IF '$DATA(DENTV)
DO DENTV
+5 IF $PIECE(X,U,27)
SET K=$SELECT($PIECE(X,U,27)=1:35,1:37)
WRITE ?46,$EXTRACT($PIECE(^DIC(220.3,K,0),U,1),1,30),?79,1,!
if IOSL-($Y#IOSL)<4
DO HOLD1
if Z5=U
QUIT
SET X(1)=$PIECE(X,U,27)
DO SPOT
QUIT
+6 IF $PIECE(X,U,44)
WRITE ?46,$EXTRACT($PIECE(^DIC(220.3,36,0),U,1),1,30),?79,1,!
if $PIECE(X,U,45)
WRITE ?46,$EXTRACT($PIECE(^DIC(220.3,38,0),U,1),1,30),?79,$PIECE(X,U,45),!
if IOSL-($Y#IOSL)<4
DO HOLD1
if Z5=U
QUIT
SET X(1)=$PIECE(X,U,44)
DO SPOT
QUIT
+7 IF $PIECE(X,U,41)
WRITE ?46,$EXTRACT($PIECE(^DIC(220.3,$PIECE(X,U,41),0),U,1),1,30),?79,1,!
if IOSL-($Y#IOSL)<4
DO HOLD1
if Z5=U
QUIT
SET X(2)=0_$PIECE(X,U,41)
IF IO=IO(0)
IF '$DATA(DENTF1)
SET DENTV=DENTV_X(2)_"01"
+8 IF $PIECE(X,U,8)
WRITE ?46,"ADMINISTRATIVE PROCEDURE",?79,1,!
if IOSL-($Y#IOSL)<4
DO HOLD1
if Z5=U
QUIT
IF IO=IO(0)
IF '$DATA(DENTF1)
SET DENTV=DENTV_3501
+9 IF $PIECE(X,U,7)'=""
SET X(2)=$SELECT($PIECE(X,U,7)="S":"04",1:"05")
WRITE ?46,$EXTRACT($PIECE(^DIC(220.3,+X(2),0),U,1),1,30),?79,1,!
if IOSL-($Y#IOSL)<4
DO HOLD1
if Z5=U
QUIT
IF IO=IO(0)
IF '$DATA(DENTF1)
SET DENTV=DENTV_X(2)_"01"
+10 FOR K=9,11:1:18,20,22:1:26,28:1:38,42:1:43
IF $PIECE(X,U,K)
DO W
if Z5=U
QUIT
+11 IF IO=IO(0)
IF '$DATA(DENTF1)
SET $PIECE(X1," ",51)=" "
SET DENTV=DENTV_X1
SET ^UTILITY($JOB,"DENTV",Q,DENTC,0)=$EXTRACT(DENTV,1,80)
KILL X1,DENTV
+12 QUIT
W WRITE ?46,$EXTRACT($PIECE(^DIC(220.3,+$PIECE($TEXT(S),";",K),0),U,1),1,30),?77,$JUSTIFY($PIECE(X,U,K),3),!
if IOSL-($Y#IOSL)<4
DO HOLD1
if Z5=U
QUIT
+1 IF IO=IO(0)
IF '$DATA(DENTF1)
SET X(2)=$PIECE($TEXT(S),";",K)
SET X(3)=$PIECE(X,U,K)
SET X(3)=0_X(3)
SET X(3)=$EXTRACT(X(3),($LENGTH(X(3))-1),$LENGTH(X(3)))
SET DENTV=DENTV_X(2)_X(3)
+2 QUIT
SPOT IF IO=IO(0)
IF '$DATA(DENTF1)
SET DENTDAT=$PIECE(X,U,1)
SET DENTDAT=$EXTRACT(DENTDAT,4,5)_$EXTRACT(DENTDAT,6,7)_$EXTRACT(DENTDAT,2,3)
+1 QUIT
HDR1 IF IOSL-($Y#IOSL)<4
DO HOLD
if Z5=U
QUIT
DO HDR^DENTAR16
+1 SET Y=$PIECE(X,U,1)
XECUTE ^DD("DD")
WRITE !,Y,?19,$PIECE(X,U,10),?25,$PIECE(X,U,2),?36,$JUSTIFY($PIECE(X,U,19),2),?41
if $PIECE(X,U,19)<9
WRITE $JUSTIFY($PIECE(X,U,6),2)
QUIT
DENTV SET X(1)=$PIECE(X,U,6)
SET X(1)=$SELECT(X(1)="":" ",1:0_X(1))
SET X(1)=$EXTRACT(X(1),$LENGTH(X(1))-1,$LENGTH(X(1)))
SET DENTDAT=$PIECE(X,U,1)
SET DENTDAT=$EXTRACT(DENTDAT,4,5)_$EXTRACT(DENTDAT,6,7)_$EXTRACT(DENTDAT,2,3)
+1 SET DENTV=1_DENTSTA_$PIECE(X,U,10)_$EXTRACT($PIECE(X,U,2),1,9)_DENTCAT_X(1)_DENTDAT
QUIT
HOLD if $DATA(ZTSK)!(IO'=IO(0))!(Z5=U)
QUIT
SET Z5=""
READ !,"Press return to continue, uparrow (^) to exit: ",Z5:DTIME
QUIT
HOLD1 DO HOLD
if Z5'=U
DO HDR^DENTAR16
QUIT
NONE SET DENTF1=1
WRITE !,"There is no treatment data for review/release for the time frame you specified",*7
GOTO EXIT1
EXIT if Z5=U
GOTO EXIT1
IF $DATA(DENTF1)
WRITE @IOF,*7
DO ERR^DENTAR16
SET H=""
FOR I=1:1
if Z5=U
QUIT
SET H=$ORDER(^UTILITY($JOB,"DENTERR",H))
if H=""
QUIT
FOR J=1:1:5
if IOSL-($Y#IOSL)<4
DO HOLD
if Z5=U
QUIT
if $DATA(^UTILITY($JOB,"DENTERR",H,J))
WRITE !,^(J)
+1 if '$DATA(DENTF1)
DO COMP^DENTAR16
WRITE !
if $DATA(DENTF1)&(Z5'=U)
DO HOLD
EXIT1 XECUTE ^%ZIS("C")
KILL DENT,DENTCAT,DENTDAT,DENTED,DENTF,DENTSD,H,H1,H2,H3,I,J,K,X
if $DATA(ZTSK)
DO EXIT1^DENTAR1
QUIT
S ;;;04;05;;;;08;;09;15;16;33;10;20;21;22;;23;;11;12;13;14;17;;24;25;26;27;28;29;30;31;18;19;32;;;;34;06
