- FHORC3 ; HISC/REL - Consult Statistics ;5/17/93 14:54
- ;;5.5;DIETETICS;;Jan 28, 2005
- D DT G:U[X KIL
- F0 R !!,"Break-down by Clinician? Y// ",X:DTIME G:'$T!(X=U) KIL S:X="" X="Y" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G F0
- S FHX1=X?1"Y".E,FHX2=0
- F1 I FHX1 R !!,"List Individual Patient Consults? N// ",X:DTIME G:'$T!(X=U) KIL S:X="" X="N" D TR^FH I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G F1
- S:FHX1 FHX2=X?1"Y".E
- K IOP,%ZIS S %ZIS("A")="Print on Device: ",%ZIS="MQ" W ! D ^%ZIS K %ZIS,IOP G:POP KIL
- I $D(IO("Q")) S FHPGM="Q1^FHORC3",FHLST="EDT^SDT^FHX1^FHX2" D EN2^FH G KIL
- U IO D Q1 D ^%ZISC K %ZIS,IOP G KIL
- KIL K ^TMP($J) G KILL^XUSCLEAN
- Q1 ; Print Consult Statistics
- K D,^TMP($J) S X1=SDT\1-.0001,X2=EDT\1+.3
- R1 S X1=$O(^FHPT("ADR",X1)) I X1<1!(X1>X2) G P1
- S FHDFN=0
- R2 S FHDFN=$O(^FHPT("ADR",X1,FHDFN)) G:FHDFN="" R1 S ADM=0
- R3 S ADM=$O(^FHPT("ADR",X1,FHDFN,ADM)) G:ADM="" R2 S DR=0
- R4 S DR=$O(^FHPT("ADR",X1,FHDFN,ADM,DR)) G:DR="" R3
- S Y=^FHPT(FHDFN,"A",ADM,"DR",DR,0)
- S ST=$P(Y,"^",8) I ST'="C" G R4
- S D1=$P(Y,"^",5),D2=$P(Y,"^",2) G:'D2 R4
- S S1=$P(Y,"^",11) S:S1="F" D2=D2_"F"
- S:'$D(D(D2)) D(D2)=0 S D(D2)=D(D2)+1
- G R4:'FHX1,R4:'D1 I '$D(^TMP($J,D1)) S NAM=$P(^VA(200,D1,0),"^",1),^TMP($J,$E(NAM,1,30),D1)=""
- I '$D(^TMP($J,D1,D2)) S ^TMP($J,D1,D2)=0
- S ^TMP($J,D1,D2)=^TMP($J,D1,D2)+1 G:'FHX2 R4
- S (DTP,W1)=$P(Y,"^",1)\1 D DTP^FH I '$D(^TMP($J,D1,D2,W1)) S ^TMP($J,D1,D2,W1)=DTP,^(W1,0)=0
- S L=^TMP($J,D1,D2,W1,0)+1,^(0)=L
- S ^TMP($J,D1,D2,W1,L)=FHDFN G R4
- P1 S DTP=SDT\1 D DTP^FH S DTE=DTP_" to " S DTP=EDT\1 D DTP^FH S DTE=DTE_DTP,PG=0 D HEAD W !?59,"Number Units",!
- S NX="",(I1,I2)=0 F K=0:0 S NX=$O(D(NX)) Q:NX="" S X=^FH(119.5,+NX,0),W1=$P(X,"^",$S(NX'["F":4,1:5)) W !,$P(X,"^",1) W:NX["F" " (FU)" W ?60,$J(D(NX),5,0),$J(D(NX)*W1,13,2) S I1=I1+D(NX),I2=D(NX)*W1+I2
- W !!,"T O T A L",?60,$J(I1,5,0),$J(I2,13,2),! Q:'FHX1 D HEAD
- S NX=":" F K=0:0 S NX=$O(^TMP($J,NX)) Q:NX="" F D1=0:0 S D1=$O(^TMP($J,NX,D1)) Q:D1<1 D P2
- W ! Q
- P2 D:$Y>55 HEAD W !!,NX S (I1,I2)=0
- S D2="" F L=0:0 S D2=$O(^TMP($J,D1,D2)) Q:D2="" S D(0)=^(D2) D P3
- W !?3,"TOTAL CONSULTS",?63,$J(I1,5,0),$J(I2,10,2) Q
- P3 S X=^FH(119.5,+D2,0),W1=$P(X,"^",$S(D2'["F":4,1:5)) D:$Y>58 HEAD W !?3,$P(X,"^",1) W:D2["F" " (FU)" W ?63,$J(D(0),5,0),$J(D(0)*W1,10,2) S I1=I1+D(0),I2=D(0)*W1+I2
- Q:'FHX2 S DTP=""
- P4 S DTP=$O(^TMP($J,D1,D2,DTP)) Q:DTP="" S D(0)=^(DTP),W1=0
- P5 S W1=$O(^TMP($J,D1,D2,DTP,W1)) G:W1="" P4 S FHDFN=^(W1)
- D PATNAME^FHOMUTL I DFN="" Q
- S Y=$G(^DPT(DFN,0)) G:Y="" P5 D PID^FHDPA
- W !?6,D(0),?17,BID,?27,$P(Y,"^",1) G P5
- DT ; Get From/To Dates
- D1 S %DT="AEPX",%DT("A")="Starting Date: " W ! D ^%DT S:$D(DTOUT) X="^" Q:U[X G:Y<1 D1 S SDT=+Y
- D2 S %DT="AEPX",%DT("A")=" Ending Date: " D ^%DT S:$D(DTOUT) X="^" Q:U[X G:Y<1 D2 S EDT=+Y
- I EDT<SDT W *7," [End before Start?] " G D1
- Q
- HEAD W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 W !?17,"D I E T E T I C C O N S U L T U N I T S",?71,"Page ",PG
- W !!?(78-$L(DTE)\2),DTE,! Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHORC3 3053 printed Feb 18, 2025@23:19:41 Page 2
- FHORC3 ; HISC/REL - Consult Statistics ;5/17/93 14:54
- +1 ;;5.5;DIETETICS;;Jan 28, 2005
- +2 DO DT
- if U[X
- GOTO KIL
- F0 READ !!,"Break-down by Clinician? Y// ",X:DTIME
- if '$TEST!(X=U)
- GOTO KIL
- if X=""
- SET X="Y"
- DO TR^FH
- IF $PIECE("YES",X,1)'=""
- IF $PIECE("NO",X,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO F0
- +1 SET FHX1=X?1"Y".E
- SET FHX2=0
- F1 IF FHX1
- READ !!,"List Individual Patient Consults? N// ",X:DTIME
- if '$TEST!(X=U)
- GOTO KIL
- if X=""
- SET X="N"
- DO TR^FH
- IF $PIECE("YES",X,1)'=""
- IF $PIECE("NO",X,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO F1
- +1 if FHX1
- SET FHX2=X?1"Y".E
- +2 KILL IOP,%ZIS
- SET %ZIS("A")="Print on Device: "
- SET %ZIS="MQ"
- WRITE !
- DO ^%ZIS
- KILL %ZIS,IOP
- if POP
- GOTO KIL
- +3 IF $DATA(IO("Q"))
- SET FHPGM="Q1^FHORC3"
- SET FHLST="EDT^SDT^FHX1^FHX2"
- DO EN2^FH
- GOTO KIL
- +4 USE IO
- DO Q1
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO KIL
- KIL KILL ^TMP($JOB)
- GOTO KILL^XUSCLEAN
- Q1 ; Print Consult Statistics
- +1 KILL D,^TMP($JOB)
- SET X1=SDT\1-.0001
- SET X2=EDT\1+.3
- R1 SET X1=$ORDER(^FHPT("ADR",X1))
- IF X1<1!(X1>X2)
- GOTO P1
- +1 SET FHDFN=0
- R2 SET FHDFN=$ORDER(^FHPT("ADR",X1,FHDFN))
- if FHDFN=""
- GOTO R1
- SET ADM=0
- R3 SET ADM=$ORDER(^FHPT("ADR",X1,FHDFN,ADM))
- if ADM=""
- GOTO R2
- SET DR=0
- R4 SET DR=$ORDER(^FHPT("ADR",X1,FHDFN,ADM,DR))
- if DR=""
- GOTO R3
- +1 SET Y=^FHPT(FHDFN,"A",ADM,"DR",DR,0)
- +2 SET ST=$PIECE(Y,"^",8)
- IF ST'="C"
- GOTO R4
- +3 SET D1=$PIECE(Y,"^",5)
- SET D2=$PIECE(Y,"^",2)
- if 'D2
- GOTO R4
- +4 SET S1=$PIECE(Y,"^",11)
- if S1="F"
- SET D2=D2_"F"
- +5 if '$DATA(D(D2))
- SET D(D2)=0
- SET D(D2)=D(D2)+1
- +6 if 'FHX1
- GOTO R4
- if 'D1
- GOTO R4
- IF '$DATA(^TMP($JOB,D1))
- SET NAM=$PIECE(^VA(200,D1,0),"^",1)
- SET ^TMP($JOB,$EXTRACT(NAM,1,30),D1)=""
- +7 IF '$DATA(^TMP($JOB,D1,D2))
- SET ^TMP($JOB,D1,D2)=0
- +8 SET ^TMP($JOB,D1,D2)=^TMP($JOB,D1,D2)+1
- if 'FHX2
- GOTO R4
- +9 SET (DTP,W1)=$PIECE(Y,"^",1)\1
- DO DTP^FH
- IF '$DATA(^TMP($JOB,D1,D2,W1))
- SET ^TMP($JOB,D1,D2,W1)=DTP
- SET ^(W1,0)=0
- +10 SET L=^TMP($JOB,D1,D2,W1,0)+1
- SET ^(0)=L
- +11 SET ^TMP($JOB,D1,D2,W1,L)=FHDFN
- GOTO R4
- P1 SET DTP=SDT\1
- DO DTP^FH
- SET DTE=DTP_" to "
- SET DTP=EDT\1
- DO DTP^FH
- SET DTE=DTE_DTP
- SET PG=0
- DO HEAD
- WRITE !?59,"Number Units",!
- +1 SET NX=""
- SET (I1,I2)=0
- FOR K=0:0
- SET NX=$ORDER(D(NX))
- if NX=""
- QUIT
- SET X=^FH(119.5,+NX,0)
- SET W1=$PIECE(X,"^",$SELECT(NX'["F":4,1:5))
- WRITE !,$PIECE(X,"^",1)
- if NX["F"
- WRITE " (FU)"
- WRITE ?60,$JUSTIFY(D(NX),5,0),$JUSTIFY(D(NX)*W1,13,2)
- SET I1=I1+D(NX)
- SET I2=D(NX)*W1+I2
- +2 WRITE !!,"T O T A L",?60,$JUSTIFY(I1,5,0),$JUSTIFY(I2,13,2),!
- if 'FHX1
- QUIT
- DO HEAD
- +3 SET NX=":"
- FOR K=0:0
- SET NX=$ORDER(^TMP($JOB,NX))
- if NX=""
- QUIT
- FOR D1=0:0
- SET D1=$ORDER(^TMP($JOB,NX,D1))
- if D1<1
- QUIT
- DO P2
- +4 WRITE !
- QUIT
- P2 if $Y>55
- DO HEAD
- WRITE !!,NX
- SET (I1,I2)=0
- +1 SET D2=""
- FOR L=0:0
- SET D2=$ORDER(^TMP($JOB,D1,D2))
- if D2=""
- QUIT
- SET D(0)=^(D2)
- DO P3
- +2 WRITE !?3,"TOTAL CONSULTS",?63,$JUSTIFY(I1,5,0),$JUSTIFY(I2,10,2)
- QUIT
- P3 SET X=^FH(119.5,+D2,0)
- SET W1=$PIECE(X,"^",$SELECT(D2'["F":4,1:5))
- if $Y>58
- DO HEAD
- WRITE !?3,$PIECE(X,"^",1)
- if D2["F"
- WRITE " (FU)"
- WRITE ?63,$JUSTIFY(D(0),5,0),$JUSTIFY(D(0)*W1,10,2)
- SET I1=I1+D(0)
- SET I2=D(0)*W1+I2
- +1 if 'FHX2
- QUIT
- SET DTP=""
- P4 SET DTP=$ORDER(^TMP($JOB,D1,D2,DTP))
- if DTP=""
- QUIT
- SET D(0)=^(DTP)
- SET W1=0
- P5 SET W1=$ORDER(^TMP($JOB,D1,D2,DTP,W1))
- if W1=""
- GOTO P4
- SET FHDFN=^(W1)
- +1 DO PATNAME^FHOMUTL
- IF DFN=""
- QUIT
- +2 SET Y=$GET(^DPT(DFN,0))
- if Y=""
- GOTO P5
- DO PID^FHDPA
- +3 WRITE !?6,D(0),?17,BID,?27,$PIECE(Y,"^",1)
- GOTO P5
- DT ; Get From/To Dates
- D1 SET %DT="AEPX"
- SET %DT("A")="Starting Date: "
- WRITE !
- DO ^%DT
- if $DATA(DTOUT)
- SET X="^"
- if U[X
- QUIT
- if Y<1
- GOTO D1
- SET SDT=+Y
- D2 SET %DT="AEPX"
- SET %DT("A")=" Ending Date: "
- DO ^%DT
- if $DATA(DTOUT)
- SET X="^"
- if U[X
- QUIT
- if Y<1
- GOTO D2
- SET EDT=+Y
- +1 IF EDT<SDT
- WRITE *7," [End before Start?] "
- GOTO D1
- +2 QUIT
- HEAD if '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- WRITE !?17,"D I E T E T I C C O N S U L T U N I T S",?71,"Page ",PG
- +1 WRITE !!?(78-$LENGTH(DTE)\2),DTE,!
- QUIT