- DENTA14 ;ISC2/SAW,HAG-TREATMENT DATA REPORT - INDIVIDUAL SITTINGS ;3/29/88
- ;;1.2;DENTAL;**16,19**;JAN 26, 1989
- ;VERSION 1.2
- S DENTC=0,DENTSD=DENTSD-.0001,%ZIS="MQ" K IO("Q") D ^%ZIS G EXIT1:IO=""
- I $D(IO("Q")) S ZTRTN="QUE^DENTA14",ZTSAVE("DENT*")="",ZTSAVE("H1")="",ZTSAVE("H2")="",ZTSAVE("U")="",ZTSAVE("Z5")="" D ^%ZTLOAD K ZTSK,ZTRTN,ZTSAVE G EXIT1
- QUE U IO 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,"A1",DENTSTA,DENTSD)) Q:DENTSD>DENTED!(DENTSD="") D:'I HDR^DENTA16 S DENT="" F J=0:0 S DENT=$O(^DENT(221,"A1",DENTSTA,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(DENTREL) Q:'$D(^DENT(221,DENT,1)) S Y(1)=$P(^(.1),"^",2) I 'Y(1)!<DENTSD1!Y(1)>DENTED Q
- S DENTC=DENTC+1 D CHK^DENTA15 Q:DENTF
- 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
- 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
- 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
- I $P(X,U,8) W ?46,"ADMINISTRATIVE PROCEDURE",?79,1,! D:IOSL-($Y#IOSL)<4 HOLD1 Q:Z5=U
- I $P(X,U,7)'="" S X(2)=$S($P(X,U,7)="S":"4",1:"5") 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
- 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
- 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
- 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)))
- Q
- HDR1 I IOSL-($Y#IOSL)<4 D HOLD Q:Z5=U D HDR^DENTA16
- S Y=$P(X,U,1) X ^DD("DD") S Y=$$DATE(Y) 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
- 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^DENTA16 Q
- NONE S DENTF1=1 W !,"There is no treatment data for the time frame you specified",*7 G EXIT1
- EXIT G EXIT1:Z5=U I $D(DENTF1) W @IOF,*7 D ERR^DENTA16 S H="" F I=1:1 Q:Z5=U S H=$O(^UTILITY($J,"DENTERR",H)) Q:H="" F J=1:1:5 D:$Y#(IOSL-2)=0 HOLD Q:Z5=U W:$D(^UTILITY($J,"DENTERR",H,J)) !,^(J)
- D:'$D(DENTF1) COMP^DENTA16 D:$D(DENTF1)&(Z5'=U) HOLD
- EXIT1 X ^%ZIS("C") K DENT,DENTCAT,DENTC,DENTDAT,DENTED,DENTF,DENTSD,H,H1,H2,H3,I,J,K,X D:$D(ZTSK) EXIT1^DENTA1 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
- DATE(Y) ;
- N HOLD,TIME,XDAT
- S XDAT=$P(Y,"@",1),TIME=$P(Y,"@",2)
- I TIME="" S HOLD=XDAT
- E S HOLD=XDAT_"@"_$E(TIME,1,5)
- Q HOLD
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDENTA14 2721 printed Feb 18, 2025@23:12:08 Page 2
- DENTA14 ;ISC2/SAW,HAG-TREATMENT DATA REPORT - INDIVIDUAL SITTINGS ;3/29/88
- +1 ;;1.2;DENTAL;**16,19**;JAN 26, 1989
- +2 ;VERSION 1.2
- +3 SET DENTC=0
- SET DENTSD=DENTSD-.0001
- SET %ZIS="MQ"
- KILL IO("Q")
- DO ^%ZIS
- if IO=""
- GOTO EXIT1
- +4 IF $DATA(IO("Q"))
- SET ZTRTN="QUE^DENTA14"
- SET ZTSAVE("DENT*")=""
- SET ZTSAVE("H1")=""
- SET ZTSAVE("H2")=""
- SET ZTSAVE("U")=""
- SET ZTSAVE("Z5")=""
- DO ^%ZTLOAD
- KILL ZTSK,ZTRTN,ZTSAVE
- GOTO EXIT1
- QUE USE IO
- 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,"A1",DENTSTA,DENTSD))
- if DENTSD>DENTED!(DENTSD="")
- QUIT
- if 'I
- DO HDR^DENTA16
- SET DENT=""
- FOR J=0:0
- SET DENT=$ORDER(^DENT(221,"A1",DENTSTA,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(DENTREL)
- if '$DATA(^DENT(221,DENT,1))
- QUIT
- SET Y(1)=$PIECE(^(.1),"^",2)
- IF 'Y(1)!<DENTSD1!Y(1)>DENTED
- QUIT
- +1 SET DENTC=DENTC+1
- DO CHK^DENTA15
- if DENTF
- QUIT
- +2 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
- QUIT
- +3 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
- QUIT
- +4 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
- +5 IF $PIECE(X,U,8)
- WRITE ?46,"ADMINISTRATIVE PROCEDURE",?79,1,!
- if IOSL-($Y#IOSL)<4
- DO HOLD1
- if Z5=U
- QUIT
- +6 IF $PIECE(X,U,7)'=""
- SET X(2)=$SELECT($PIECE(X,U,7)="S":"4",1:"5")
- 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
- +7 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
- +8 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 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)))
- +2 QUIT
- HDR1 IF IOSL-($Y#IOSL)<4
- DO HOLD
- if Z5=U
- QUIT
- DO HDR^DENTA16
- +1 SET Y=$PIECE(X,U,1)
- XECUTE ^DD("DD")
- SET Y=$$DATE(Y)
- 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
- 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^DENTA16
- QUIT
- NONE SET DENTF1=1
- WRITE !,"There is no treatment data for the time frame you specified",*7
- GOTO EXIT1
- EXIT if Z5=U
- GOTO EXIT1
- IF $DATA(DENTF1)
- WRITE @IOF,*7
- DO ERR^DENTA16
- 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 $Y#(IOSL-2)=0
- DO HOLD
- if Z5=U
- QUIT
- if $DATA(^UTILITY($JOB,"DENTERR",H,J))
- WRITE !,^(J)
- +1 if '$DATA(DENTF1)
- DO COMP^DENTA16
- if $DATA(DENTF1)&(Z5'=U)
- DO HOLD
- EXIT1 XECUTE ^%ZIS("C")
- KILL DENT,DENTCAT,DENTC,DENTDAT,DENTED,DENTF,DENTSD,H,H1,H2,H3,I,J,K,X
- if $DATA(ZTSK)
- DO EXIT1^DENTA1
- 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
- DATE(Y) ;
- +1 NEW HOLD,TIME,XDAT
- +2 SET XDAT=$PIECE(Y,"@",1)
- SET TIME=$PIECE(Y,"@",2)
- +3 IF TIME=""
- SET HOLD=XDAT
- +4 IF '$TEST
- SET HOLD=XDAT_"@"_$EXTRACT(TIME,1,5)
- +5 QUIT HOLD