- SCRPW51 ;RENO/KEITH - Encounters by DSS Identifier/DSS ID by Frequency (OP0, OP1, OP2) ; 15 Jul 98 02:38PM
- ;;5.3;Scheduling;**144,339,466**;AUG 13, 1993;Build 2
- S SDSTA=$G(SDSTA,2)
- S SDHD1="Encounters by DSS Identifier/DSS ID by Frequency "
- S SDHD1=SDHD1_$S(SDSTA=8:"(IP0, IP1, IP2)",1:"(OP0, OP1, OP2)")
- D RQUE^SCRPW50("START^SCRPW51",SDHD1) Q
- ;
- START ;Print report
- K ^TMP("SCRPW",$J) S (SDSTOP,SDOUT)=0,SDT=SD("FYD")
- F S SDT=$O(^SCE("B",SDT)) Q:'SDT!SDOUT!(SDT>SD("EDT")) S SDOE=0 F S SDOE=$O(^SCE("B",SDT,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE),SDIV=$P(SDOE0,U,11) I $$VALID() D SET(SDIV) D:SDMD SET(0)
- G:SDOUT EXIT S (SDVCT,SDIV)=""
- F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV="" D DLIST,STOP Q:SDOUT D SUB0 S SDSC="" F S SDSC=$O(^TMP("SCRPW",$J,SDIV,SDSC)) Q:'SDSC!SDOUT F SDMF="M","F" D SUBT
- G:SDOUT EXIT S SDLINE="",$P(SDLINE,"-",(IOM+1))="" D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDTIT(1)="<*> ENCOUNTERS BY DSS IDENTIFIER "_$S(SDSTA=8:"(IP0, IP1, IP2)",1:"(OP0, OP1, OP2)")_" <*>",SDPG=0 D:$E(IOST)="C" DISP0^SCRPW23
- S SDFY=1700+(100*$E(SD("FYD")))+$E(SD("FYD"),2,3)
- I '$D(^TMP("SCRPW",$J)) S SDPAGE=1,SDX="No activity found within report parameters." S SDIV=0 D DHDR^SCRPW40(1,.SDTIT),HDR G:SDOUT EXIT W !!?(IOM-$L(SDX)\2),SDX G EXIT ;SD*5.3*339 added required input parameters to SCRPW40 call
- G:SDOUT EXIT S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT S SDIV=SDIV(SDIVN) D DPRT(.SDIV)
- G:SDOUT EXIT I SDVCT>1 S SDIV=0 D DPRT(.SDIV)
- EXIT G EXIT^SCRPW52
- ;
- SUB0 F SDMF="M","F" D
- .S (SDCT,DFN)=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDMF,DFN)) Q:'DFN S SDCT=SDCT+1
- .S ^TMP("SCRPW",$J,SDIV,SDMF,"UNI")=SDCT Q
- Q
- ;
- SUBT S (SDUNI,DFN)=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDSC,"SEX",SDMF,DFN)) Q:'DFN S SDUNI=SDUNI+1
- S ^TMP("SCRPW",$J,SDIV,SDSC,"SEX",SDMF,"UNI")=SDUNI
- Q
- ;
- DPRT(SDIV) ;Print division
- ;Required input: SDIV=division ifn or '0' for combined divisions
- D DHDR^SCRPW40(2,.SDTIT) S SDTIT(1)="<*> ENCOUNTERS BY DSS IDENTIFIER "_$S(SDSTA=8:"(IP0, IP1)",1:"(OP0, 0P1)")_" <*>"
- F SDI=0:1:11 S SDRTOT(SDI)=0
- S SDGTOT=0,SDPAGE=1 D HDR,HD1 Q:SDOUT S SDSC=0 F S SDSC=$O(^TMP("SCRPW",$J,SDIV,SDSC)) Q:'SDSC!SDOUT D PLINE
- Q:SDOUT W ! F SDI=1:1:132 W "="
- W !,"TOTAL:" F SDYMO=0:1:11 W ?(9+(9*SDYMO)),$J(SDRTOT(SDYMO),7,0)
- W ?117,$J(SDGTOT,15,0)
- D ^SCRPW52
- Q
- ;
- PLINE ;Print output line
- Q:'$D(^TMP("SCRPW",$J,SDIV,SDSC,"P")) N SDYMO
- S SDYMO=0 F S SDYMO=$O(^TMP("SCRPW",$J,SDIV,SDSC,"P","YMO",SDYMO)) Q:'SDYMO S SDYMO($$MO())=^TMP("SCRPW",$J,SDIV,SDSC,"P","YMO",SDYMO)
- D:$Y>(IOSL-4) HDR,HD1 Q:SDOUT
- S SDTCT=0 W !?2,SDSC F SDYMO=0:1:11 D
- .S SDCT=+$G(SDYMO(SDYMO)),SDTCT=SDTCT+SDCT,SDRTOT(SDYMO)=SDRTOT(SDYMO)+SDCT,SDGTOT=SDGTOT+SDCT W ?(9+(9*SDYMO)),$J(SDCT,7,0) Q
- W ?117,$J(SDTCT,15,0)
- Q
- ;
- MO() ;Determine FY month
- N X S X=+$E(SDYMO,4,5),X=$S(X>9:$E(X,2),1:X+2) Q X
- ;
- HDR ;Print header
- I $E(IOST)="C",SDPG N DIR S DIR(0)="E" W ! D ^DIR S SDOUT=Y'=1 Q:SDOUT
- D STOP Q:SDOUT W:SDPG!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0)
- N SDI S SDI=0 W SDLINE F S SDI=$O(SDTIT(SDI)) Q:'SDI W !?(IOM-$L(SDTIT(SDI))\2),SDTIT(SDI)
- W !,SDLINE,!,"For Fiscal Year activity through ",SD("PEDT"),!,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1,SDPG=1 Q
- ;
- HD1 ;Print subheader
- Q:SDOUT W !,"DSS ID",?9 S SDM1=0 F SDMO=10,11,12,"01","02","03","04","05","06","07","08","09" D
- .W ?(9+(9*SDM1)),SDMO,"/",$S(SDM1<3:SDFY,1:SDFY+1) S SDM1=SDM1+1 Q
- W ?122,"FYTD TOTAL",!,"-------" F SDM1=0:1:11 W ?(9+(9*SDM1)),"-------"
- W ?117,"---------------" Q
- ;
- DLIST ;Create alphabetic list of divisions found
- Q:'SDIV S SDX=$P($G(^DG(40.8,SDIV,0)),U) S:'$L(SDX) SDX="*** UNKNOWN ***" S SDIV(SDX)=SDIV,SDVCT=SDVCT+1 Q
- ;
- VALID() ;Check encounter record
- I $P(SDOE0,U,4),$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q 0
- I SDIV,$$DIV(),$P(SDOE0,U,2),'$P(SDOE0,U,6),$P(SDOE0,U,7),$P(SDOE0,U,12)=SDSTA Q 1
- Q 0
- ;
- DIV() ;Check division
- Q:'SDDIV 1 Q $D(SDDIV(SDIV))
- ;
- STOP ;Check for stop task request
- S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
- ;
- SET(SDIV) ;Set division lists
- ;Required input: SDIV=division ifn or '0' for summary
- S SDSTOP=SDSTOP+1 I SDSTOP#2000=0 D STOP^SCRPW40 Q:SDOUT
- N SDX,SDI,SDPSC,SDSSC
- D SCPC^SCRPW25(.SDX) S SDI=$O(SDX("")),SDPSC=$P(SDX(SDI),U) Q:'SDPSC
- K SDX D SCSC^SCRPW25(.SDX) S SDI=$O(SDX("")),SDSSC=$P(SDX(SDI),U)
- S SDMF=$P($G(^DPT($P(SDOE0,U,2),0)),U,2) I '$L(SDMF)!("MF"'[SDMF) Q
- S SDSCN=$P($G(^DIC(40.7,+SDPSC,0)),U,2) D:SDSCN SET1(SDSCN,"P")
- S SDSCN=$P($G(^DIC(40.7,+SDSSC,0)),U,2) D:SDSCN SET1(SDSCN,"S")
- Q
- ;
- SET1(SDC,SDPS) ;Set TMP global
- ;Required input: SDC=stop code AMIS number
- ;Optional input: SDPS='P' or 'S' to indicate primary or secondary
- S ^TMP("SCRPW",$J,SDIV,SDC,SDPS,"ENC")=$G(^TMP("SCRPW",$J,SDIV,SDC,SDPS,"ENC"))+1
- S ^TMP("SCRPW",$J,SDIV,SDC,"SEX",SDMF)=$G(^TMP("SCRPW",$J,SDIV,SDC,"SEX",SDMF))+1
- S ^TMP("SCRPW",$J,SDIV,SDC,"SEX",SDMF,$P(SDOE0,U,2))=""
- S ^TMP("SCRPW",$J,SDIV,SDMF,$P(SDOE0,U,2))="" Q:SDPS="S"
- S ^TMP("SCRPW",$J,SDIV,SDMF,"ENC")=$G(^TMP("SCRPW",$J,SDIV,SDMF,"ENC"))+1
- S ^TMP("SCRPW",$J,SDIV,SDC,SDPS,"YMO",+$E(SDOE0,1,5))=$G(^TMP("SCRPW",$J,SDIV,SDC,SDPS,"YMO",+$E(SDOE0,1,5)))+1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW51 5290 printed Feb 19, 2025@00:10:16 Page 2
- SCRPW51 ;RENO/KEITH - Encounters by DSS Identifier/DSS ID by Frequency (OP0, OP1, OP2) ; 15 Jul 98 02:38PM
- +1 ;;5.3;Scheduling;**144,339,466**;AUG 13, 1993;Build 2
- +2 SET SDSTA=$GET(SDSTA,2)
- +3 SET SDHD1="Encounters by DSS Identifier/DSS ID by Frequency "
- +4 SET SDHD1=SDHD1_$SELECT(SDSTA=8:"(IP0, IP1, IP2)",1:"(OP0, OP1, OP2)")
- +5 DO RQUE^SCRPW50("START^SCRPW51",SDHD1)
- QUIT
- +6 ;
- START ;Print report
- +1 KILL ^TMP("SCRPW",$JOB)
- SET (SDSTOP,SDOUT)=0
- SET SDT=SD("FYD")
- +2 FOR
- SET SDT=$ORDER(^SCE("B",SDT))
- if 'SDT!SDOUT!(SDT>SD("EDT"))
- QUIT
- SET SDOE=0
- FOR
- SET SDOE=$ORDER(^SCE("B",SDT,SDOE))
- if 'SDOE!SDOUT
- QUIT
- SET SDOE0=$$GETOE^SDOE(SDOE)
- SET SDIV=$PIECE(SDOE0,U,11)
- IF $$VALID()
- DO SET(SDIV)
- if SDMD
- DO SET(0)
- +3 if SDOUT
- GOTO EXIT
- SET (SDVCT,SDIV)=""
- +4 FOR
- SET SDIV=$ORDER(^TMP("SCRPW",$JOB,SDIV))
- if SDIV=""
- QUIT
- DO DLIST
- DO STOP
- if SDOUT
- QUIT
- DO SUB0
- SET SDSC=""
- FOR
- SET SDSC=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDSC))
- if 'SDSC!SDOUT
- QUIT
- FOR SDMF="M","F"
- DO SUBT
- +5 if SDOUT
- GOTO EXIT
- SET SDLINE=""
- SET $PIECE(SDLINE,"-",(IOM+1))=""
- DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- SET SDPNOW=$PIECE(Y,":",1,2)
- SET SDTIT(1)="<*> ENCOUNTERS BY DSS IDENTIFIER "_$SELECT(SDSTA=8:"(IP0, IP1, IP2)",1:"(OP0, OP1, OP2)")_" <*>"
- SET SDPG=0
- if $EXTRACT(IOST)="C"
- DO DISP0^SCRPW23
- +6 SET SDFY=1700+(100*$EXTRACT(SD("FYD")))+$EXTRACT(SD("FYD"),2,3)
- +7 ;SD*5.3*339 added required input parameters to SCRPW40 call
- IF '$DATA(^TMP("SCRPW",$JOB))
- SET SDPAGE=1
- SET SDX="No activity found within report parameters."
- SET SDIV=0
- DO DHDR^SCRPW40(1,.SDTIT)
- DO HDR
- if SDOUT
- GOTO EXIT
- WRITE !!?(IOM-$LENGTH(SDX)\2),SDX
- GOTO EXIT
- +8 if SDOUT
- GOTO EXIT
- SET SDIVN=""
- FOR
- SET SDIVN=$ORDER(SDIV(SDIVN))
- if SDIVN=""!SDOUT
- QUIT
- SET SDIV=SDIV(SDIVN)
- DO DPRT(.SDIV)
- +9 if SDOUT
- GOTO EXIT
- IF SDVCT>1
- SET SDIV=0
- DO DPRT(.SDIV)
- EXIT GOTO EXIT^SCRPW52
- +1 ;
- SUB0 FOR SDMF="M","F"
- Begin DoDot:1
- +1 SET (SDCT,DFN)=0
- FOR
- SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDMF,DFN))
- if 'DFN
- QUIT
- SET SDCT=SDCT+1
- +2 SET ^TMP("SCRPW",$JOB,SDIV,SDMF,"UNI")=SDCT
- QUIT
- End DoDot:1
- +3 QUIT
- +4 ;
- SUBT SET (SDUNI,DFN)=0
- FOR
- SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDSC,"SEX",SDMF,DFN))
- if 'DFN
- QUIT
- SET SDUNI=SDUNI+1
- +1 SET ^TMP("SCRPW",$JOB,SDIV,SDSC,"SEX",SDMF,"UNI")=SDUNI
- +2 QUIT
- +3 ;
- DPRT(SDIV) ;Print division
- +1 ;Required input: SDIV=division ifn or '0' for combined divisions
- +2 DO DHDR^SCRPW40(2,.SDTIT)
- SET SDTIT(1)="<*> ENCOUNTERS BY DSS IDENTIFIER "_$SELECT(SDSTA=8:"(IP0, IP1)",1:"(OP0, 0P1)")_" <*>"
- +3 FOR SDI=0:1:11
- SET SDRTOT(SDI)=0
- +4 SET SDGTOT=0
- SET SDPAGE=1
- DO HDR
- DO HD1
- if SDOUT
- QUIT
- SET SDSC=0
- FOR
- SET SDSC=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDSC))
- if 'SDSC!SDOUT
- QUIT
- DO PLINE
- +5 if SDOUT
- QUIT
- WRITE !
- FOR SDI=1:1:132
- WRITE "="
- +6 WRITE !,"TOTAL:"
- FOR SDYMO=0:1:11
- WRITE ?(9+(9*SDYMO)),$JUSTIFY(SDRTOT(SDYMO),7,0)
- +7 WRITE ?117,$JUSTIFY(SDGTOT,15,0)
- +8 DO ^SCRPW52
- +9 QUIT
- +10 ;
- PLINE ;Print output line
- +1 if '$DATA(^TMP("SCRPW",$JOB,SDIV,SDSC,"P"))
- QUIT
- NEW SDYMO
- +2 SET SDYMO=0
- FOR
- SET SDYMO=$ORDER(^TMP("SCRPW",$JOB,SDIV,SDSC,"P","YMO",SDYMO))
- if 'SDYMO
- QUIT
- SET SDYMO($$MO())=^TMP("SCRPW",$JOB,SDIV,SDSC,"P","YMO",SDYMO)
- +3 if $Y>(IOSL-4)
- DO HDR
- DO HD1
- if SDOUT
- QUIT
- +4 SET SDTCT=0
- WRITE !?2,SDSC
- FOR SDYMO=0:1:11
- Begin DoDot:1
- +5 SET SDCT=+$GET(SDYMO(SDYMO))
- SET SDTCT=SDTCT+SDCT
- SET SDRTOT(SDYMO)=SDRTOT(SDYMO)+SDCT
- SET SDGTOT=SDGTOT+SDCT
- WRITE ?(9+(9*SDYMO)),$JUSTIFY(SDCT,7,0)
- QUIT
- End DoDot:1
- +6 WRITE ?117,$JUSTIFY(SDTCT,15,0)
- +7 QUIT
- +8 ;
- MO() ;Determine FY month
- +1 NEW X
- SET X=+$EXTRACT(SDYMO,4,5)
- SET X=$SELECT(X>9:$EXTRACT(X,2),1:X+2)
- QUIT X
- +2 ;
- HDR ;Print header
- +1 IF $EXTRACT(IOST)="C"
- IF SDPG
- NEW DIR
- SET DIR(0)="E"
- WRITE !
- DO ^DIR
- SET SDOUT=Y'=1
- if SDOUT
- QUIT
- +2 DO STOP
- if SDOUT
- QUIT
- if SDPG!($EXTRACT(IOST)="C")
- WRITE $$XY^SCRPW50(IOF,1,0)
- if $X
- WRITE $$XY^SCRPW50("",0,0)
- +3 NEW SDI
- SET SDI=0
- WRITE SDLINE
- FOR
- SET SDI=$ORDER(SDTIT(SDI))
- if 'SDI
- QUIT
- WRITE !?(IOM-$LENGTH(SDTIT(SDI))\2),SDTIT(SDI)
- +4 WRITE !,SDLINE,!,"For Fiscal Year activity through ",SD("PEDT"),!,"Date printed: ",SDPNOW,?(IOM-6-$LENGTH(SDPAGE)),"Page: ",SDPAGE,!,SDLINE
- SET SDPAGE=SDPAGE+1
- SET SDPG=1
- QUIT
- +5 ;
- HD1 ;Print subheader
- +1 if SDOUT
- QUIT
- WRITE !,"DSS ID",?9
- SET SDM1=0
- FOR SDMO=10,11,12,"01","02","03","04","05","06","07","08","09"
- Begin DoDot:1
- +2 WRITE ?(9+(9*SDM1)),SDMO,"/",$SELECT(SDM1<3:SDFY,1:SDFY+1)
- SET SDM1=SDM1+1
- QUIT
- End DoDot:1
- +3 WRITE ?122,"FYTD TOTAL",!,"-------"
- FOR SDM1=0:1:11
- WRITE ?(9+(9*SDM1)),"-------"
- +4 WRITE ?117,"---------------"
- QUIT
- +5 ;
- DLIST ;Create alphabetic list of divisions found
- +1 if 'SDIV
- QUIT
- SET SDX=$PIECE($GET(^DG(40.8,SDIV,0)),U)
- if '$LENGTH(SDX)
- SET SDX="*** UNKNOWN ***"
- SET SDIV(SDX)=SDIV
- SET SDVCT=SDVCT+1
- QUIT
- +2 ;
- VALID() ;Check encounter record
- +1 IF $PIECE(SDOE0,U,4)
- IF $PIECE($GET(^SC($PIECE(SDOE0,U,4),0)),U,17)="Y"
- QUIT 0
- +2 IF SDIV
- IF $$DIV()
- IF $PIECE(SDOE0,U,2)
- IF '$PIECE(SDOE0,U,6)
- IF $PIECE(SDOE0,U,7)
- IF $PIECE(SDOE0,U,12)=SDSTA
- QUIT 1
- +3 QUIT 0
- +4 ;
- DIV() ;Check division
- +1 if 'SDDIV
- QUIT 1
- QUIT $DATA(SDDIV(SDIV))
- +2 ;
- STOP ;Check for stop task request
- +1 if $DATA(ZTQUEUED)
- SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
- QUIT
- +2 ;
- SET(SDIV) ;Set division lists
- +1 ;Required input: SDIV=division ifn or '0' for summary
- +2 SET SDSTOP=SDSTOP+1
- IF SDSTOP#2000=0
- DO STOP^SCRPW40
- if SDOUT
- QUIT
- +3 NEW SDX,SDI,SDPSC,SDSSC
- +4 DO SCPC^SCRPW25(.SDX)
- SET SDI=$ORDER(SDX(""))
- SET SDPSC=$PIECE(SDX(SDI),U)
- if 'SDPSC
- QUIT
- +5 KILL SDX
- DO SCSC^SCRPW25(.SDX)
- SET SDI=$ORDER(SDX(""))
- SET SDSSC=$PIECE(SDX(SDI),U)
- +6 SET SDMF=$PIECE($GET(^DPT($PIECE(SDOE0,U,2),0)),U,2)
- IF '$LENGTH(SDMF)!("MF"'[SDMF)
- QUIT
- +7 SET SDSCN=$PIECE($GET(^DIC(40.7,+SDPSC,0)),U,2)
- if SDSCN
- DO SET1(SDSCN,"P")
- +8 SET SDSCN=$PIECE($GET(^DIC(40.7,+SDSSC,0)),U,2)
- if SDSCN
- DO SET1(SDSCN,"S")
- +9 QUIT
- +10 ;
- SET1(SDC,SDPS) ;Set TMP global
- +1 ;Required input: SDC=stop code AMIS number
- +2 ;Optional input: SDPS='P' or 'S' to indicate primary or secondary
- +3 SET ^TMP("SCRPW",$JOB,SDIV,SDC,SDPS,"ENC")=$GET(^TMP("SCRPW",$JOB,SDIV,SDC,SDPS,"ENC"))+1
- +4 SET ^TMP("SCRPW",$JOB,SDIV,SDC,"SEX",SDMF)=$GET(^TMP("SCRPW",$JOB,SDIV,SDC,"SEX",SDMF))+1
- +5 SET ^TMP("SCRPW",$JOB,SDIV,SDC,"SEX",SDMF,$PIECE(SDOE0,U,2))=""
- +6 SET ^TMP("SCRPW",$JOB,SDIV,SDMF,$PIECE(SDOE0,U,2))=""
- if SDPS="S"
- QUIT
- +7 SET ^TMP("SCRPW",$JOB,SDIV,SDMF,"ENC")=$GET(^TMP("SCRPW",$JOB,SDIV,SDMF,"ENC"))+1
- +8 SET ^TMP("SCRPW",$JOB,SDIV,SDC,SDPS,"YMO",+$EXTRACT(SDOE0,1,5))=$GET(^TMP("SCRPW",$JOB,SDIV,SDC,SDPS,"YMO",+$EXTRACT(SDOE0,1,5)))+1
- QUIT