- 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 Mar 13, 2025@20:51:20 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
