DENTPCD ;ISC2/SAW,HAG-COST DISTRIBUTION REPORT ;4/29/96 11:36 ;
;;1.2;DENTAL;**4,24**;JAN 26, 1989
W ! S %DT("A")="Enter CDR REPORT date MONTH/YEAR: ",%DT="AENP" D ^%DT Q:Y<0 K %DT("A") S DATE=Y
D P S (TD,R,E,F)=0 F X=1:1:7 S TD=TD+$P(A(X),"^"),R=R+$P(A(X),"^",2),E=E+$P(A(X),"^",3),F=F+$P(A(X),"^",4)
W !!,"The total number of days spent in the area of education is: ",E,!,"Please distribute these days into the three components Instructional,",!,"Administrative and Continuing Education by answering the following",!,"two prompts."
I W !!,"Number of days to distribute to Instructional component: " R X:DTIME G EXIT:X=""!(X="^") G:X["?" I
I X>E W !!,*7,"You cannot enter a number larger than ",E G I
S P1=$S(E>0:X/E,1:0)
A W !,"Number of days to distribute to Administrative component: " R X:DTIME G EXIT:X=""!(X="^") G:X["?" A
S P2=$S(E>0:X/E,1:0) I P1+P2>E W !!,*7,"You only have a total of ",E," days to distribute?",!,"Try again." K P1,P2 G I
S P3=1-(P1+P2) W !,"Therefore ",P3*E," days are distributed to Continuing Education." R X:3
S Z3=$O(^DENT(225,0)) G:Z3<1 W I $O(^DENT(225,Z3))>1 D
.S DIC="^DENT(225,",DIC(0)="AEMNQZ",DIC("A")="Select STATION.DIVISION: "
.D ^DIC Q:Y<0 K DIC Q
S Z1=$S(Z3=1:Z3,1:+Y) S (DENTSTA,Z3)=$P(^DENT(225,Z1,0),U,1) I DENTSTA="" D W Q
W !!,"Note: This report is AUTOMATICALLY QUEUED to print, you must specify a printer.",!! S IOP="Q" D ^%ZIS G CLOSE:IO=""
S ZTRTN="QUE^DENTPCD",ZTSAVE("A0")="",ZTSAVE("A1")="",ZTSAVE("A2")="",ZTSAVE("DATE")="",ZTSAVE("DENTSTA")="",ZTSAVE("DT2")="",ZTSAVE("P1")="",ZTSAVE("P2")="",ZTSAVE("P3")=""
S ZTSAVE("TD")="",ZTSAVE("E")="",ZTSAVE("R")="",ZTSAVE("F")="" D ^%ZTLOAD K ZTSK,ZTRTN,ZTSAVE G CLOSE
QUE U IO F I=1:1:18 S B(I)=""
S A1=A0 F I=0:0 S A1=$O(^DENT(221,"B",A1)),A3="" Q:A1=""!(A1>A2) F J=0:0 S A3=$O(^DENT(221,"B",A1,A3)) Q:A3="" S X=^DENT(221,A3,0),P=$P(X,"^",19),N=$S(P>8:18,P=4:16,P=5:17,1:$P(X,"^",6)) S:'N N=1 S:$P(X,"^",9)!($P(X,"^",11)) B(N)=B(N)+2 D P11
S B=0 F I=1:1:18 S B=B+$P(B(I),"^")
I B=0 W @IOF,*7,!,"There are no Treatment Data entries for ",DT2,".",!,"Unable to continue." G CLOSE
S:TD R=R/TD,E=E/TD,F=F/TD
D ^DENTPCD1 G CLOSE
P11 I $P(X,"^",27)!($P(X,"^",44)) S L=$S($P(X,"^",27)=1:35,$P(X,"^",27)=3:37,1:36),Z=1,B(N)=B(N)+($P(^DIC(220.3,L,0),"^",2)*Z) S:$P(X,"^",45) B(N)=B(N)+$P(X,"^",45) Q
F M=7,9,11:1:18,20,22:1:26,28:1:38,42,43 I $P(X,"^",M) S L=$P($T(S),";",M),Z=$P(X,"^",M) S:M=7 L=$S(Z="S":4,Z="C":5),Z=1 S:L=18 B(N)=B(N)+(Z-1),Z=1 S B(N)=B(N)+($P(^DIC(220.3,L,0),"^",2)*Z)
Q
P S DT2=$E(DATE,4,5),DT2=$P($T(DATE),";",DT2+2),(A0,A1)=$E(DATE,1,5)_"00",A2=$E(A0,1,5)_31.2359 F I=1:1:7 S A(I)="^^^"
F I=0:0 S A1=$O(^DENT(224,"B",A1)),A3="" Q:A1=""!(A1>A2) F J=0:0 S A3=$O(^DENT(224,"B",A1,A3)) Q:A3="" S Y=1,X=^DENT(224,A3,0) F K=2,4:1:8 S $P(A(Y),"^")=$P(A(Y),"^")+$P(X,"^",K),Y=Y+1
S A1=A0 F I=0:0 S A1=$O(^DENT(226,"B",A1)) Q:A1=""!(A1>A2) F K=0:0 S A3=$O(^DENT(226,"B",A1,A3)) Q:A3="" D T
F I=1:1:7 F L=2:1:4 S $P(A(I),"^",L)=$P(A(I),"^",L)+4\8
Q
W W !!,"Stations have not been entered in the Dental Site Parameter file.",!,"You must enter a station before you can use this option" G EXIT
T S X=^DENT(226,A3,0),A4=$E($P(X,"^",3),1) Q:A4=0!(A4=3) S A4=$S(A4=2:1,A4=4:3,A4=5:2,A4>5:7,1:A4)
S A5=$P(X,"^",4) Q:A5="A" S A5=$S(A5="R":2,A5="E":3,1:4),$P(A(A4),"^",A5)=$P(A(A4),"^",A5)+$P(X,"^",5) Q
S ;;;;;;;;8;;9;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;6
DATE ;;JANUARY;FEBRUARY;MARCH;APRIL;MAY;JUNE;JULY;AUGUST;SEPTEMBER;OCTOBER;NOVEMBER;DECEMBER
CLOSE X ^%ZIS("C")
EXIT K %DT,A,B,A0,A1,A2,A3,A4,A5,C,DATE,DENTSTA,DT2,E,F,I,IO("Q"),J,K,L,M,N,P,P1,P2,P3,R,RT,ST,TD,X,Y,Z,Z1,Z3 K:$D(ZTSK) ^%ZTSK(ZTSK),ZTSK Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDENTPCD 3729 printed Dec 13, 2024@01:46:41 Page 2
DENTPCD ;ISC2/SAW,HAG-COST DISTRIBUTION REPORT ;4/29/96 11:36 ;
+1 ;;1.2;DENTAL;**4,24**;JAN 26, 1989
+2 WRITE !
SET %DT("A")="Enter CDR REPORT date MONTH/YEAR: "
SET %DT="AENP"
DO ^%DT
if Y<0
QUIT
KILL %DT("A")
SET DATE=Y
+3 DO P
SET (TD,R,E,F)=0
FOR X=1:1:7
SET TD=TD+$PIECE(A(X),"^")
SET R=R+$PIECE(A(X),"^",2)
SET E=E+$PIECE(A(X),"^",3)
SET F=F+$PIECE(A(X),"^",4)
+4 WRITE !!,"The total number of days spent in the area of education is: ",E,!,"Please distribute these days into the three components Instructional,",!,"Administrative and Continuing Education by answering the following",!,"two prompts."
I WRITE !!,"Number of days to distribute to Instructional component: "
READ X:DTIME
if X=""!(X="^")
GOTO EXIT
if X["?"
GOTO I
+1 IF X>E
WRITE !!,*7,"You cannot enter a number larger than ",E
GOTO I
+2 SET P1=$SELECT(E>0:X/E,1:0)
A WRITE !,"Number of days to distribute to Administrative component: "
READ X:DTIME
if X=""!(X="^")
GOTO EXIT
if X["?"
GOTO A
+1 SET P2=$SELECT(E>0:X/E,1:0)
IF P1+P2>E
WRITE !!,*7,"You only have a total of ",E," days to distribute?",!,"Try again."
KILL P1,P2
GOTO I
+2 SET P3=1-(P1+P2)
WRITE !,"Therefore ",P3*E," days are distributed to Continuing Education."
READ X:3
+3 SET Z3=$ORDER(^DENT(225,0))
if Z3<1
GOTO W
IF $ORDER(^DENT(225,Z3))>1
Begin DoDot:1
+4 SET DIC="^DENT(225,"
SET DIC(0)="AEMNQZ"
SET DIC("A")="Select STATION.DIVISION: "
+5 DO ^DIC
if Y<0
QUIT
KILL DIC
QUIT
End DoDot:1
+6 SET Z1=$SELECT(Z3=1:Z3,1:+Y)
SET (DENTSTA,Z3)=$PIECE(^DENT(225,Z1,0),U,1)
IF DENTSTA=""
DO W
QUIT
+7 WRITE !!,"Note: This report is AUTOMATICALLY QUEUED to print, you must specify a printer.",!!
SET IOP="Q"
DO ^%ZIS
if IO=""
GOTO CLOSE
+8 SET ZTRTN="QUE^DENTPCD"
SET ZTSAVE("A0")=""
SET ZTSAVE("A1")=""
SET ZTSAVE("A2")=""
SET ZTSAVE("DATE")=""
SET ZTSAVE("DENTSTA")=""
SET ZTSAVE("DT2")=""
SET ZTSAVE("P1")=""
SET ZTSAVE("P2")=""
SET ZTSAVE("P3")=""
+9 SET ZTSAVE("TD")=""
SET ZTSAVE("E")=""
SET ZTSAVE("R")=""
SET ZTSAVE("F")=""
DO ^%ZTLOAD
KILL ZTSK,ZTRTN,ZTSAVE
GOTO CLOSE
QUE USE IO
FOR I=1:1:18
SET B(I)=""
+1 SET A1=A0
FOR I=0:0
SET A1=$ORDER(^DENT(221,"B",A1))
SET A3=""
if A1=""!(A1>A2)
QUIT
FOR J=0:0
SET A3=$ORDER(^DENT(221,"B",A1,A3))
if A3=""
QUIT
SET X=^DENT(221,A3,0)
SET P=$PIECE(X,"^",19)
SET N=$SELECT(P>8:18,P=4:16,P=5:17,1:$PIECE(X,"^",6))
if 'N
SET N=1
if $PIECE(X,"^",9)!($PIECE(X,"^",11))
SET B(N)=B(N)+2
DO P11
+2 SET B=0
FOR I=1:1:18
SET B=B+$PIECE(B(I),"^")
+3 IF B=0
WRITE @IOF,*7,!,"There are no Treatment Data entries for ",DT2,".",!,"Unable to continue."
GOTO CLOSE
+4 if TD
SET R=R/TD
SET E=E/TD
SET F=F/TD
+5 DO ^DENTPCD1
GOTO CLOSE
P11 IF $PIECE(X,"^",27)!($PIECE(X,"^",44))
SET L=$SELECT($PIECE(X,"^",27)=1:35,$PIECE(X,"^",27)=3:37,1:36)
SET Z=1
SET B(N)=B(N)+($PIECE(^DIC(220.3,L,0),"^",2)*Z)
if $PIECE(X,"^",45)
SET B(N)=B(N)+$PIECE(X,"^",45)
QUIT
+1 FOR M=7,9,11:1:18,20,22:1:26,28:1:38,42,43
IF $PIECE(X,"^",M)
SET L=$PIECE($TEXT(S),";",M)
SET Z=$PIECE(X,"^",M)
if M=7
SET L=$SELECT(Z="S":4,Z="C":5)
SET Z=1
if L=18
SET B(N)=B(N)+(Z-1)
SET Z=1
SET B(N)=B(N)+($PIECE(^DIC(220.3,L,0),"^",2)*Z)
+2 QUIT
P SET DT2=$EXTRACT(DATE,4,5)
SET DT2=$PIECE($TEXT(DATE),";",DT2+2)
SET (A0,A1)=$EXTRACT(DATE,1,5)_"00"
SET A2=$EXTRACT(A0,1,5)_31.2359
FOR I=1:1:7
SET A(I)="^^^"
+1 FOR I=0:0
SET A1=$ORDER(^DENT(224,"B",A1))
SET A3=""
if A1=""!(A1>A2)
QUIT
FOR J=0:0
SET A3=$ORDER(^DENT(224,"B",A1,A3))
if A3=""
QUIT
SET Y=1
SET X=^DENT(224,A3,0)
FOR K=2,4:1:8
SET $PIECE(A(Y),"^")=$PIECE(A(Y),"^")+$PIECE(X,"^",K)
SET Y=Y+1
+2 SET A1=A0
FOR I=0:0
SET A1=$ORDER(^DENT(226,"B",A1))
if A1=""!(A1>A2)
QUIT
FOR K=0:0
SET A3=$ORDER(^DENT(226,"B",A1,A3))
if A3=""
QUIT
DO T
+3 FOR I=1:1:7
FOR L=2:1:4
SET $PIECE(A(I),"^",L)=$PIECE(A(I),"^",L)+4\8
+4 QUIT
W WRITE !!,"Stations have not been entered in the Dental Site Parameter file.",!,"You must enter a station before you can use this option"
GOTO EXIT
T SET X=^DENT(226,A3,0)
SET A4=$EXTRACT($PIECE(X,"^",3),1)
if A4=0!(A4=3)
QUIT
SET A4=$SELECT(A4=2:1,A4=4:3,A4=5:2,A4>5:7,1:A4)
+1 SET A5=$PIECE(X,"^",4)
if A5="A"
QUIT
SET A5=$SELECT(A5="R":2,A5="E":3,1:4)
SET $PIECE(A(A4),"^",A5)=$PIECE(A(A4),"^",A5)+$PIECE(X,"^",5)
QUIT
S ;;;;;;;;8;;9;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;6
DATE ;;JANUARY;FEBRUARY;MARCH;APRIL;MAY;JUNE;JULY;AUGUST;SEPTEMBER;OCTOBER;NOVEMBER;DECEMBER
CLOSE XECUTE ^%ZIS("C")
EXIT KILL %DT,A,B,A0,A1,A2,A3,A4,A5,C,DATE,DENTSTA,DT2,E,F,I,IO("Q"),J,K,L,M,N,P,P1,P2,P3,R,RT,ST,TD,X,Y,Z,Z1,Z3
if $DATA(ZTSK)
KILL ^%ZTSK(ZTSK),ZTSK
QUIT
