SCRPW16 ;RENO/KEITH - Encounter 'Action Required' Report ; 01 Jan 99 9:27 PM
;;5.3;Scheduling;**139,144,155,161,336,466**;AUG 13, 1993;Build 2
N SD,SDDIV,ZTSAVE,%DT,DIR,DTOUT,DUOUT,X,Y
D TITL^SCRPW50("Encounter 'Action Required' Report")
G:'$$DIVA^SCRPW17(.SDDIV) EXIT
D SUBT^SCRPW50("**** Date Range Selection ****")
W ! S %DT="AEPX",%DT("A")="Beginning date: " D ^%DT G:Y<1 EXIT S SD("BDT")=Y
EDT S %DT("A")=" Ending date: " W ! D ^%DT G:Y<1 EXIT
I Y<SD("BDT") W !!,$C(7),"End date cannot be before begin date!",! G EDT
S SD("EDT")=Y_.999999
D SUBT^SCRPW50("*** Report Format Selection ***")
S DIR(0)="S^D:DETAILED REPORT;S:STATISTICS ONLY",DIR("A")="Select report type",DIR("B")="DETAILED REPORT" D ^DIR G:($D(DTOUT)!$D(DUOUT)) EXIT S SD("STAT")=Y
G:'$$ASK^SCRPW17(0,0,.SD,"",$S(SD("STAT")="D":"A",1:"A^1"),1) EXIT
I SD("STAT")="D" K DIR S DIR(0)="Y",DIR("A")="Would you like a separate page for every clinic",DIR("B")="NO" W ! D ^DIR G:($D(DTOUT)!$D(DUOUT)) EXIT S SD("PAGE")=Y
W !!,"This report requires 132 column output.",! S ZTSAVE("SDDIV")="",ZTSAVE("SDDIV(")="",ZTSAVE("SD(")="" D EN^XUTMDEVQ("RUN^SCRPW16","Enc. 'Act. Req.' Rpt.",.ZTSAVE) G EXIT
;
RUN ;Print report
K ^TMP("SCRPW",$J),SDSEG,SDSTR,SDT S (SDOUT,SDLK)=0
;If date range includes TODAY, update appointment status
I SD("BDT")'>DT,SD("EDT")'<DT D G:SDOUT EXIT
.D LOCK Q:SDOUT!'SDLK
.N SDBEG,SDEND,X,%,%H,%I D NOW^%DTC S SDBEG=DT,SDEND=%
.S SDEND=($P(SDEND,".")-1)_"."_999999
.D EN^SDAMQ3(SDBEG,SDEND) K ^TMP("SDSTATS",$J) L -^SCRPW16("ACTION REQUIRED REPORT") Q
S SDT(2)=$$T2^SCRPW18(),SDDT=SD("BDT"),SDSEG=$$SEGS^SCRPW18(.SDSEG) D STR^SCRPW18(.SDSTR) S (SDOUT,SDSTOP)=0,SDMD="",SDMD=$O(SDDIV(SDMD)),SDMD=$O(SDDIV(SDMD)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDMD=1
F S SDDT=$O(^SCE("B",SDDT)) Q:'SDDT!(SDDT>SD("EDT"))!SDOUT S SDOE=0 F S SDOE=$O(^SCE("B",SDDT,SDOE)) Q:'SDOE!SDOUT D EVAL
G:SDOUT EXIT
S SDIV="" F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV="" D STOP Q:SDOUT D
.S SDFCT(SDIV)=0,SDCG="" F S SDCG=$O(^TMP("SCRPW",$J,SDIV,1,SDCG)) Q:SDCG="" S SDTCT=0 D CT1 S ^TMP("SCRPW",$J,SDIV,1,SDCG)=SDTCT
.Q
G:SDOUT EXIT
S SDIV="" F S SDIV=$O(SDDIV(SDIV)) Q:'SDIV S SDIV(SDDIV(SDIV))=SDIV
I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE()
I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI
D HD1^SCRPW18 D:$E(IOST)="C" DISP0^SCRPW23 I '$O(^TMP("SCRPW",$J,0)) S SDIV=0 D DHDR^SCRPW40(3,.SDT) D HDR^SCRPW18(.SDT,"") Q:SDOUT S SDX="No activity found within selected report parameters!" W !!?(IOM-$L(SDX)\2),SDX G EXIT
S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT S SDIV=SDIV(SDIVN) D DPRT(.SDIV)
S SDI=0,SDI=$O(^TMP("SCRPW",$J,SDI)),SDMD=$O(^TMP("SCRPW",$J,SDI))
G:SDOUT EXIT I SDMD S SDIV=0 D DPRT(.SDIV)
I 'SDOUT,$E(IOST)="C" N DIR S DIR(0)="E" D ^DIR
EXIT K SD,SDARY,SDBDAY,SDCCT,SDCL,SDCLN,SDCT,SDDPT,SDDT,SDEDAY,SDFCT,SDFF,SDI,SDLINE,SDOE,SDOE0,SDORD,SDPAGE,SDPNOW,DFN,SDPT0,SDPTNA,SDR,SDSN,SDSTR
K SDT,SDTCT,SDCG,SDX,SDMD,SDSTOP,%,SDFOUND,SDDEF,SDCO,SDAP0,SDDIV,SDIV,SDIVN,SDCI,SDCLPT,SDCLPTC,SDDIS,SDV,SDSDV,SDSDVC0,SDSEG,SDTY,SDY,%DT
K SDLK,SCRPW16,SDCS,SDCO,SDZ,SDOUT,DIR,DTOUT,DUOUT,X,Y,ZTSAVE D KVA^VADPT,END^SCRPW50 Q
;
LOCK ;Prevent simultaneous runs of the appointment status update
F SDI=1:1 L +^SCRPW16("ACTION REQUIRED REPORT"):1 D Q:SDI>600!SDOUT!SDLK
.I $T S SDLK=1 Q
.D:SDI#60=0 STOP
.Q
Q
;
DPRT(SDIV) ;Print report for a division
D DHDR^SCRPW40(3,.SDT) I '$D(^TMP("SCRPW",$J,SDIV)) D HDR^SCRPW18(.SDT,"") Q:SDOUT S X="No 'action required' activity found for this division!" W !!?(132-$L(X)\2),X Q
D:SDIV&(SD("STAT")="D") DET^SCRPW18 Q:SDOUT D STAT^SCRPW18 Q
;
STOP ;Check for stop task request
S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
;
EVAL S SDSTOP=SDSTOP+1 I SDSTOP#3000=0 D STOP Q:SDOUT
S SDOE0=$$GETOE^SDOE(SDOE),SDIV=$P(SDOE0,U,11) Q:$P(SDOE0,U,6)!'SDIV Q:$$STCK(SDOE0) Q:'$$DIV(SDIV)
S SDCL=+$P(SDOE0,U,4),SDCLN=$S('SDCL:"**NONE**",1:$P(^SC(SDCL,0),U)),SDCG=$P($G(^SC(SDCL,0)),U,31),SDCG=$S(SD("FORMAT")'["G":"**NONE**",SDCG:$P(^SD(409.67,SDCG,0),U),1:"**NONE**")
I SD("FORMAT")="SC",'$D(SD("CLINIC",SDCLN)) Q
I SD("FORMAT")="RC",(($O(SD("CLINIC",""))]SDCLN)!(SDCLN]$O(SD("CLINIC",""),-1))) Q
I "SS^RS"[SD("FORMAT"),'$$STCO() Q
I SD("FORMAT")="SG",$P(SD("GROUP"),U,2)'=SDCG Q
S DFN=$P(SDOE0,U,2) Q:'DFN D DEM^VADPT M SDDPT=VADM
I SD("ORDER")="A" S SDORD=SDDPT(1)
I SD("ORDER")="D" S SDORD=$P(SDOE0,U)
I SD("ORDER")="T" S SDSN=$P(SDDPT(2),U),SDORD=$E(SDSN,8,9)_$E(SDSN,6,7)_$E(SDSN,4,5)_$E(SDSN,1,3)_"."
K SDARY M SDARY=SDSEG S (SDFOUND,SDY)=0 I $$CHEK^SCRPW18(SDOE,.SDARY,.SDSTR) S SDI="" F S SDI=$O(SDARY(SDI)) Q:SDI="" S SDX="" F S SDX=$O(SDARY(SDI,SDX)) Q:SDX="" D SET(SDX)
K SDX D CLASK^SDCO2(SDOE,.SDX)
; SD*5.3*336 so all existing and future classification types are pulled
I $D(SDX) S SDI=0 F S SDI=$O(SDX(SDI)) Q:'SDI I $P(SDX(SDI),U,2)="" D
. I '$D(^SD(409.41,SDI,0)) S SDX="Classification required" D SET(SDX) Q
. S SDX=$P($G(^SD(409.41,SDI,0)),U,1)_" classification required"
. D SET(SDX)
I 'SDFOUND,$P(SDOE0,U,8)=1,'$$CODT^SDCOU(DFN,SDDT,SDCL) S SDI=1,SDX="No check-out date" D SET(SDX)
I 'SDFOUND S SDCO="" D EN^SDCOM(SDOE,0,,.SDCO) Q:SDCO>0
I 'SDFOUND D
.K SDZ D GETDX^SDOE(SDOE,"SDZ") I '$G(SDZ) D SET("No diagnosis on file")
.K SDZ D GETPRV^SDOE(SDOE,"SDZ") I '$G(SDZ) D SET("No provider on file")
.K SDZ D GETCPT^SDOE(SDOE,"SDZ") I '$G(SDZ) D SET("No procedure code on file")
I 'SDFOUND S SDX="Unknown reason" D SET(SDX)
D EV1(SDIV) D:SDMD EV1(0)
Q
;
STCK(SDOE0) ;Check Status for action required
;Returns 0 if status=action required (14) or
; status=inpatients (8) and check out date=""
; 1 if non-count clinic, OOS and otherwise
I $P(SDOE0,U,4),'$$CLINIC^SDAMU($P(SDOE0,U,4)) Q 1
I $P(SDOE0,U,12)=8,$P(SDOE0,U,7)="" Q 0
I $P(SDOE0,U,12)'=14 Q 1
Q 0
;
EV1(SDIV) S ^TMP("SCRPW",$J,SDIV,1,SDCG,SDCLN,SDORD,DFN,SDOE)=SDOE0,^TMP("SCRPW",$J,SDIV,3,DFN)=SDDPT(1)_U_SDDPT(2)
Q
;
DIV(SDIV) ;Evaluate division
;Required input: SDIV=division ifn
Q:'SDDIV 1 Q $D(SDDIV(SDIV))
;
STCO() ;Evaluate Stop Code
Q:'SDCL 0 S SDCS=$P($G(^SC(SDCL,0)),U,7) Q:'SDCS 0 S SDCS=$P($G(^DIC(40.7,SDCS,0)),U,2) Q:'SDCS 0
I SD("FORMAT")="SS" Q $D(SD("STOPCODE",SDCS))
I (($O(SD("STOPCODE",""))]SDCS)!(SDCS]$O(SD("STOPCODE",""),-1))) Q 0
Q 1
;
SET(SDX) D SET1(SDIV) D:SDMD SET1(0) Q
;
SET1(SDIV) S SDY=SDY+1,^TMP("SCRPW",$J,SDIV,1,SDCG,SDCLN,SDORD,DFN,SDOE,SDY)=SDX
S ^TMP("SCRPW",$J,SDIV,2,SDCG,SDX)=$G(^TMP("SCRPW",$J,SDIV,2,SDCG,SDX))+1,SDFOUND=1
Q
;
CT1 S SDCLN="" F S SDCLN=$O(^TMP("SCRPW",$J,SDIV,1,SDCG,SDCLN)) Q:SDCLN="" S SDCCT=0 D CT2 S ^TMP("SCRPW",$J,SDIV,1,SDCG,SDCLN)=SDCCT
Q
;
CT2 S SDORD="" F S SDORD=$O(^TMP("SCRPW",$J,SDIV,1,SDCG,SDCLN,SDORD)) Q:SDORD="" S DFN="" F S DFN=$O(^TMP("SCRPW",$J,SDIV,1,SDCG,SDCLN,SDORD,DFN)) Q:DFN="" D CT3
Q
;
CT3 S SDOE=0 F S SDOE=$O(^TMP("SCRPW",$J,SDIV,1,SDCG,SDCLN,SDORD,DFN,SDOE)) Q:'SDOE S SDFCT(SDIV)=SDFCT(SDIV)+1,SDTCT=SDTCT+1,SDCCT=SDCCT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPW16 7197 printed Dec 13, 2024@02:43:20 Page 2
SCRPW16 ;RENO/KEITH - Encounter 'Action Required' Report ; 01 Jan 99 9:27 PM
+1 ;;5.3;Scheduling;**139,144,155,161,336,466**;AUG 13, 1993;Build 2
+2 NEW SD,SDDIV,ZTSAVE,%DT,DIR,DTOUT,DUOUT,X,Y
+3 DO TITL^SCRPW50("Encounter 'Action Required' Report")
+4 if '$$DIVA^SCRPW17(.SDDIV)
GOTO EXIT
+5 DO SUBT^SCRPW50("**** Date Range Selection ****")
+6 WRITE !
SET %DT="AEPX"
SET %DT("A")="Beginning date: "
DO ^%DT
if Y<1
GOTO EXIT
SET SD("BDT")=Y
EDT SET %DT("A")=" Ending date: "
WRITE !
DO ^%DT
if Y<1
GOTO EXIT
+1 IF Y<SD("BDT")
WRITE !!,$CHAR(7),"End date cannot be before begin date!",!
GOTO EDT
+2 SET SD("EDT")=Y_.999999
+3 DO SUBT^SCRPW50("*** Report Format Selection ***")
+4 SET DIR(0)="S^D:DETAILED REPORT;S:STATISTICS ONLY"
SET DIR("A")="Select report type"
SET DIR("B")="DETAILED REPORT"
DO ^DIR
if ($DATA(DTOUT)!$DATA(DUOUT))
GOTO EXIT
SET SD("STAT")=Y
+5 if '$$ASK^SCRPW17(0,0,.SD,"",$SELECT(SD("STAT")="D"
GOTO EXIT
+6 IF SD("STAT")="D"
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Would you like a separate page for every clinic"
SET DIR("B")="NO"
WRITE !
DO ^DIR
if ($DATA(DTOUT)!$DATA(DUOUT))
GOTO EXIT
SET SD("PAGE")=Y
+7 WRITE !!,"This report requires 132 column output.",!
SET ZTSAVE("SDDIV")=""
SET ZTSAVE("SDDIV(")=""
SET ZTSAVE("SD(")=""
DO EN^XUTMDEVQ("RUN^SCRPW16","Enc. 'Act. Req.' Rpt.",.ZTSAVE)
GOTO EXIT
+8 ;
RUN ;Print report
+1 KILL ^TMP("SCRPW",$JOB),SDSEG,SDSTR,SDT
SET (SDOUT,SDLK)=0
+2 ;If date range includes TODAY, update appointment status
+3 IF SD("BDT")'>DT
IF SD("EDT")'<DT
Begin DoDot:1
+4 DO LOCK
if SDOUT!'SDLK
QUIT
+5 NEW SDBEG,SDEND,X,%,%H,%I
DO NOW^%DTC
SET SDBEG=DT
SET SDEND=%
+6 SET SDEND=($PIECE(SDEND,".")-1)_"."_999999
+7 DO EN^SDAMQ3(SDBEG,SDEND)
KILL ^TMP("SDSTATS",$JOB)
LOCK -^SCRPW16("ACTION REQUIRED REPORT")
QUIT
End DoDot:1
if SDOUT
GOTO EXIT
+8 SET SDT(2)=$$T2^SCRPW18()
SET SDDT=SD("BDT")
SET SDSEG=$$SEGS^SCRPW18(.SDSEG)
DO STR^SCRPW18(.SDSTR)
SET (SDOUT,SDSTOP)=0
SET SDMD=""
SET SDMD=$ORDER(SDDIV(SDMD))
SET SDMD=$ORDER(SDDIV(SDMD))
if $PIECE(SDDIV,U,2)="ALL DIVISIONS"
SET SDMD=1
+9 FOR
SET SDDT=$ORDER(^SCE("B",SDDT))
if 'SDDT!(SDDT>SD("EDT"))!SDOUT
QUIT
SET SDOE=0
FOR
SET SDOE=$ORDER(^SCE("B",SDDT,SDOE))
if 'SDOE!SDOUT
QUIT
DO EVAL
+10 if SDOUT
GOTO EXIT
+11 SET SDIV=""
FOR
SET SDIV=$ORDER(^TMP("SCRPW",$JOB,SDIV))
if SDIV=""
QUIT
DO STOP
if SDOUT
QUIT
Begin DoDot:1
+12 SET SDFCT(SDIV)=0
SET SDCG=""
FOR
SET SDCG=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDCG))
if SDCG=""
QUIT
SET SDTCT=0
DO CT1
SET ^TMP("SCRPW",$JOB,SDIV,1,SDCG)=SDTCT
+13 QUIT
End DoDot:1
+14 if SDOUT
GOTO EXIT
+15 SET SDIV=""
FOR
SET SDIV=$ORDER(SDDIV(SDIV))
if 'SDIV
QUIT
SET SDIV(SDDIV(SDIV))=SDIV
+16 IF 'SDDIV
IF $PIECE(SDDIV,U,2)'="ALL DIVISIONS"
SET SDIV($PIECE(SDDIV,U,2))=$$PRIM^VASITE()
+17 IF $PIECE(SDDIV,U,2)="ALL DIVISIONS"
SET SDI=0
FOR
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDI))
if 'SDI
QUIT
SET SDX=$PIECE($GET(^DG(40.8,SDI,0)),U)
if $LENGTH(SDX)
SET SDIV(SDX)=SDI
+18 DO HD1^SCRPW18
if $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
IF '$ORDER(^TMP("SCRPW",$JOB,0))
SET SDIV=0
DO DHDR^SCRPW40(3,.SDT)
DO HDR^SCRPW18(.SDT,"")
if SDOUT
QUIT
SET SDX="No activity found within selected report parameters!"
WRITE !!?(IOM-$LENGTH(SDX)\2),SDX
GOTO EXIT
+19 SET SDIVN=""
FOR
SET SDIVN=$ORDER(SDIV(SDIVN))
if SDIVN=""!SDOUT
QUIT
SET SDIV=SDIV(SDIVN)
DO DPRT(.SDIV)
+20 SET SDI=0
SET SDI=$ORDER(^TMP("SCRPW",$JOB,SDI))
SET SDMD=$ORDER(^TMP("SCRPW",$JOB,SDI))
+21 if SDOUT
GOTO EXIT
IF SDMD
SET SDIV=0
DO DPRT(.SDIV)
+22 IF 'SDOUT
IF $EXTRACT(IOST)="C"
NEW DIR
SET DIR(0)="E"
DO ^DIR
EXIT KILL SD,SDARY,SDBDAY,SDCCT,SDCL,SDCLN,SDCT,SDDPT,SDDT,SDEDAY,SDFCT,SDFF,SDI,SDLINE,SDOE,SDOE0,SDORD,SDPAGE,SDPNOW,DFN,SDPT0,SDPTNA,SDR,SDSN,SDSTR
+1 KILL SDT,SDTCT,SDCG,SDX,SDMD,SDSTOP,%,SDFOUND,SDDEF,SDCO,SDAP0,SDDIV,SDIV,SDIVN,SDCI,SDCLPT,SDCLPTC,SDDIS,SDV,SDSDV,SDSDVC0,SDSEG,SDTY,SDY,%DT
+2 KILL SDLK,SCRPW16,SDCS,SDCO,SDZ,SDOUT,DIR,DTOUT,DUOUT,X,Y,ZTSAVE
DO KVA^VADPT
DO END^SCRPW50
QUIT
+3 ;
LOCK ;Prevent simultaneous runs of the appointment status update
+1 FOR SDI=1:1
LOCK +^SCRPW16("ACTION REQUIRED REPORT"):1
Begin DoDot:1
+2 IF $TEST
SET SDLK=1
QUIT
+3 if SDI#60=0
DO STOP
+4 QUIT
End DoDot:1
if SDI>600!SDOUT!SDLK
QUIT
+5 QUIT
+6 ;
DPRT(SDIV) ;Print report for a division
+1 DO DHDR^SCRPW40(3,.SDT)
IF '$DATA(^TMP("SCRPW",$JOB,SDIV))
DO HDR^SCRPW18(.SDT,"")
if SDOUT
QUIT
SET X="No 'action required' activity found for this division!"
WRITE !!?(132-$LENGTH(X)\2),X
QUIT
+2 if SDIV&(SD("STAT")="D")
DO DET^SCRPW18
if SDOUT
QUIT
DO STAT^SCRPW18
QUIT
+3 ;
STOP ;Check for stop task request
+1 if $GET(ZTQUEUED)
SET (SDOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
QUIT
+2 ;
EVAL SET SDSTOP=SDSTOP+1
IF SDSTOP#3000=0
DO STOP
if SDOUT
QUIT
+1 SET SDOE0=$$GETOE^SDOE(SDOE)
SET SDIV=$PIECE(SDOE0,U,11)
if $PIECE(SDOE0,U,6)!'SDIV
QUIT
if $$STCK(SDOE0)
QUIT
if '$$DIV(SDIV)
QUIT
+2 SET SDCL=+$PIECE(SDOE0,U,4)
SET SDCLN=$SELECT('SDCL:"**NONE**",1:$PIECE(^SC(SDCL,0),U))
SET SDCG=$PIECE($GET(^SC(SDCL,0)),U,31)
SET SDCG=$SELECT(SD("FORMAT")'["G":"**NONE**",SDCG:$PIECE(^SD(409.67,SDCG,0),U),1:"**NONE**")
+3 IF SD("FORMAT")="SC"
IF '$DATA(SD("CLINIC",SDCLN))
QUIT
+4 IF SD("FORMAT")="RC"
IF (($ORDER(SD("CLINIC",""))]SDCLN)!(SDCLN]$ORDER(SD("CLINIC",""),-1)))
QUIT
+5 IF "SS^RS"[SD("FORMAT")
IF '$$STCO()
QUIT
+6 IF SD("FORMAT")="SG"
IF $PIECE(SD("GROUP"),U,2)'=SDCG
QUIT
+7 SET DFN=$PIECE(SDOE0,U,2)
if 'DFN
QUIT
DO DEM^VADPT
MERGE SDDPT=VADM
+8 IF SD("ORDER")="A"
SET SDORD=SDDPT(1)
+9 IF SD("ORDER")="D"
SET SDORD=$PIECE(SDOE0,U)
+10 IF SD("ORDER")="T"
SET SDSN=$PIECE(SDDPT(2),U)
SET SDORD=$EXTRACT(SDSN,8,9)_$EXTRACT(SDSN,6,7)_$EXTRACT(SDSN,4,5)_$EXTRACT(SDSN,1,3)_"."
+11 KILL SDARY
MERGE SDARY=SDSEG
SET (SDFOUND,SDY)=0
IF $$CHEK^SCRPW18(SDOE,.SDARY,.SDSTR)
SET SDI=""
FOR
SET SDI=$ORDER(SDARY(SDI))
if SDI=""
QUIT
SET SDX=""
FOR
SET SDX=$ORDER(SDARY(SDI,SDX))
if SDX=""
QUIT
DO SET(SDX)
+12 KILL SDX
DO CLASK^SDCO2(SDOE,.SDX)
+13 ; SD*5.3*336 so all existing and future classification types are pulled
+14 IF $DATA(SDX)
SET SDI=0
FOR
SET SDI=$ORDER(SDX(SDI))
if 'SDI
QUIT
IF $PIECE(SDX(SDI),U,2)=""
Begin DoDot:1
+15 IF '$DATA(^SD(409.41,SDI,0))
SET SDX="Classification required"
DO SET(SDX)
QUIT
+16 SET SDX=$PIECE($GET(^SD(409.41,SDI,0)),U,1)_" classification required"
+17 DO SET(SDX)
End DoDot:1
+18 IF 'SDFOUND
IF $PIECE(SDOE0,U,8)=1
IF '$$CODT^SDCOU(DFN,SDDT,SDCL)
SET SDI=1
SET SDX="No check-out date"
DO SET(SDX)
+19 IF 'SDFOUND
SET SDCO=""
DO EN^SDCOM(SDOE,0,,.SDCO)
if SDCO>0
QUIT
+20 IF 'SDFOUND
Begin DoDot:1
+21 KILL SDZ
DO GETDX^SDOE(SDOE,"SDZ")
IF '$GET(SDZ)
DO SET("No diagnosis on file")
+22 KILL SDZ
DO GETPRV^SDOE(SDOE,"SDZ")
IF '$GET(SDZ)
DO SET("No provider on file")
+23 KILL SDZ
DO GETCPT^SDOE(SDOE,"SDZ")
IF '$GET(SDZ)
DO SET("No procedure code on file")
End DoDot:1
+24 IF 'SDFOUND
SET SDX="Unknown reason"
DO SET(SDX)
+25 DO EV1(SDIV)
if SDMD
DO EV1(0)
+26 QUIT
+27 ;
STCK(SDOE0) ;Check Status for action required
+1 ;Returns 0 if status=action required (14) or
+2 ; status=inpatients (8) and check out date=""
+3 ; 1 if non-count clinic, OOS and otherwise
+4 IF $PIECE(SDOE0,U,4)
IF '$$CLINIC^SDAMU($PIECE(SDOE0,U,4))
QUIT 1
+5 IF $PIECE(SDOE0,U,12)=8
IF $PIECE(SDOE0,U,7)=""
QUIT 0
+6 IF $PIECE(SDOE0,U,12)'=14
QUIT 1
+7 QUIT 0
+8 ;
EV1(SDIV) SET ^TMP("SCRPW",$JOB,SDIV,1,SDCG,SDCLN,SDORD,DFN,SDOE)=SDOE0
SET ^TMP("SCRPW",$JOB,SDIV,3,DFN)=SDDPT(1)_U_SDDPT(2)
+1 QUIT
+2 ;
DIV(SDIV) ;Evaluate division
+1 ;Required input: SDIV=division ifn
+2 if 'SDDIV
QUIT 1
QUIT $DATA(SDDIV(SDIV))
+3 ;
STCO() ;Evaluate Stop Code
+1 if 'SDCL
QUIT 0
SET SDCS=$PIECE($GET(^SC(SDCL,0)),U,7)
if 'SDCS
QUIT 0
SET SDCS=$PIECE($GET(^DIC(40.7,SDCS,0)),U,2)
if 'SDCS
QUIT 0
+2 IF SD("FORMAT")="SS"
QUIT $DATA(SD("STOPCODE",SDCS))
+3 IF (($ORDER(SD("STOPCODE",""))]SDCS)!(SDCS]$ORDER(SD("STOPCODE",""),-1)))
QUIT 0
+4 QUIT 1
+5 ;
SET(SDX) DO SET1(SDIV)
if SDMD
DO SET1(0)
QUIT
+1 ;
SET1(SDIV) SET SDY=SDY+1
SET ^TMP("SCRPW",$JOB,SDIV,1,SDCG,SDCLN,SDORD,DFN,SDOE,SDY)=SDX
+1 SET ^TMP("SCRPW",$JOB,SDIV,2,SDCG,SDX)=$GET(^TMP("SCRPW",$JOB,SDIV,2,SDCG,SDX))+1
SET SDFOUND=1
+2 QUIT
+3 ;
CT1 SET SDCLN=""
FOR
SET SDCLN=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDCG,SDCLN))
if SDCLN=""
QUIT
SET SDCCT=0
DO CT2
SET ^TMP("SCRPW",$JOB,SDIV,1,SDCG,SDCLN)=SDCCT
+1 QUIT
+2 ;
CT2 SET SDORD=""
FOR
SET SDORD=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDCG,SDCLN,SDORD))
if SDORD=""
QUIT
SET DFN=""
FOR
SET DFN=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDCG,SDCLN,SDORD,DFN))
if DFN=""
QUIT
DO CT3
+1 QUIT
+2 ;
CT3 SET SDOE=0
FOR
SET SDOE=$ORDER(^TMP("SCRPW",$JOB,SDIV,1,SDCG,SDCLN,SDORD,DFN,SDOE))
if 'SDOE
QUIT
SET SDFCT(SDIV)=SDFCT(SDIV)+1
SET SDTCT=SDTCT+1
SET SDCCT=SDCCT+1
+1 QUIT
