ORY153 ;SLC/JLI Hep-C Post Init ; Feb 04, 2003@11:44:15
;;3.0;ORDER ENTRY/RESULTS REPORTING;**153**;Dec 17, 1997
;
PRE ;Pre-init
Q
POST ;Post-init
N OLDVAL
S OLDVAL=""
S OLDVAL=$$GET^XPAR("SYS^PKG","ORHEPC ABNORMAL START",1,"I")
D MAIN
D:$L(OLDVAL) EN^XPAR("SYS","ORHEPC ABNORMAL START",1,OLDVAL)
D UDABS
D UDRPTS
D QUE ;rebuild ARS xref this version
Q
;
MAIN ; main (initial) parameter transport routine
K ^TMP($J,"XPARRSTR")
N ENT,IDX,ROOT,REF,VAL,I
S ROOT=$NAME(^TMP($J,"XPARRSTR")),ROOT=$E(ROOT,1,$L(ROOT)-1)_","
LOAD ; load data into ^TMP (expects ROOT to be defined)
S I=1 F S REF=$T(DATA+I) Q:REF="" S VAL=$T(DATA+I+1) D
. S I=I+2,REF=$P(REF,";",3,999),VAL=$P(VAL,";",3,999)
. S @(ROOT_REF)=VAL
Q
XX2 S IDX=0,ENT="PKG."_"ORDER ENTRY/RESULTS REPORTING"
F S IDX=$O(^TMP($J,"XPARRSTR",IDX)) Q:'IDX D
. N PAR,INST,VAL,ERR
. S PAR=$P(^TMP($J,"XPARRSTR",IDX,"KEY"),U),INST=$P(^("KEY"),U,2)
. M VAL=^TMP($J,"XPARRSTR",IDX,"VAL")
. D EN^XPAR(ENT,PAR,INST,.VAL,.ERR)
K ^TMP($J,"XPARRSTR")
Q
;
UDABS ;Update abnormal result start date PKG level to installation date
;update date range in abnormal result report
D EN^XPAR("PKG","ORHEPC ABNORMAL START",1,$$DT^XLFDT())
N DRANGEID,ABSID,STDT,IX,SD,TD,TXTC,DIFF
S (IX,ABSID,STDT,SD,TX,JX,DIFF)=0,TXTC=""
S ABSID=$O(^ORD(102.21,"B","RPT ABNORMAL RESULTS",0))
S DRANGEID=$O(^ORD(102.21,"B","CTP SEARCH DATE RANGE",0))
S STDT=$$GET^XPAR("SYS^PKG","ORHEPC ABNORMAL START",1,"I")
S TD=$$DT^XLFDT()
S DIFF=$$FMDIFF^XLFDT(STDT,TD,1)
S DIFF=+$FN(DIFF,"T")
I DIFF>184 S STDT="T-184"
S SD=$$FMTE^XLFDT(STDT)
S TD=$$FMTE^XLFDT(TD)
S TXTC="from "_SD_" through "_TD
F S IX=$O(^ORD(102.21,ABSID,1,IX)) Q:('IX)!JX D
. I $P(^ORD(102.21,ABSID,1,IX,0),U,2)=DRANGEID D
. . S $P(^ORD(102.21,ABSID,1,IX,0),U,4)=TXTC
. . S ^ORD(102.21,ABSID,1,IX,1,1,0)=STDT_":T"
. . K ^ORD(102.21,ABSID,1,IX,1,"B")
. . S ^ORD(102.21,ABSID,1,IX,1,"B",STDT_":T",1)="",JX=1 Q
Q
UDRPTS ;
CSLTRPT ;
N IX,JX,RPTID,CTGVL
S (IX,JX,RPTID,CTGVL)=0
S RPTID=$O(^ORD(102.21,"B","RPT CONSULT FOLLOW-UP",0))
F S IX=$O(^ORD(102.21,RPTID,1,IX)) Q:('IX)!JX D
. I $P(^(IX,0),U,4)="ALL SERVICES" D
. . S CTGVL=$O(^ORD(100.98,"B","CSLT",0))
. . S ^ORD(102.21,RPTID,1,IX,1,1,0)=CTGVL
. . K ^ORD(102.21,RPTID,1,IX,1,"B") S ^ORD(102.21,RPTID,1,IX,1,"B",CTGVL,1)="",JX=1
SCHRPT ;
S (IX,JX,RPTID,CTGVL)=0
S RPTID=$O(^ORD(102.21,"B","RPT SCHEDULED/DUE ACTIVITY",0))
F S IX=$O(^ORD(102.21,RPTID,1,IX)) Q:('IX)!JX D
. I $P(^(IX,0),U,4)="IMAGING" D
. . S CTGVL=$O(^ORD(100.98,"B","IMAGING",0))
. . S ^ORD(102.21,RPTID,1,IX,1,1,0)=CTGVL
. . K ^ORD(102.21,RPTID,1,IX,1,"B") S ^ORD(102.21,RPTID,1,IX,1,"B",CTGVL,1)=""
Q
QUE ; -- Task xref job
N ZTIO,ZTDTH,ZTDESC,ZTRTN,ZTSK,ZTSAVE
S ZTIO="",ZTDTH=$H,ZTDESC="Rebuild ARS xref on Orders file #100"
S ZTRTN="ARS^ORY153" D ^%ZTLOAD
S X="Task "_$S($G(ZTSK):"#"_ZTSK,1:"not")_" started to rebuild ^OR(100,""ARS"")." D BMES^XPDUTL(X)
Q
ARS ; -- Add Patient subscript to xref for test sites
N ORFIRST,ORIDX,ORIFN,ORVP,ORDT
S ORIDX=$Q(^OR(100,"ARS")) Q:ORIDX'["ARS" Q:$L(ORIDX,",")>4
S ORFIRST=+$P(ORIDX,",",4) F S ORIDX=$Q(@ORIDX) Q:ORIDX'?1"^OR(100,""ARS"",".E S ORIFN=+$P(ORIDX,",",4) S:ORIFN<ORFIRST ORFIRST=ORIFN
K ^OR(100,"ARS") S ORIFN=ORFIRST-.1
F S ORIFN=$O(^OR(100,ORIFN)) Q:ORIFN<1 D
. S ORDT=+$G(^OR(100,ORIFN,7)) Q:ORDT<1 S ORVP=$P($G(^(0)),U,2)
. S ^OR(100,"ARS",ORVP,9999999-ORDT,ORIFN)=""
Q
DATA ; parameter data
;;12848,"KEY")
;;ORHEPC ABNORMAL START^1
;;12848,"VAL")
;;FEB 14, 2003
ORY153 ;SLC/JLI Hep-C Post Init ; Feb 04, 2003@11:44:15
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**153**;Dec 17, 1997
+2 ;
PRE ;Pre-init
+1 QUIT
POST ;Post-init
+1 NEW OLDVAL
+2 SET OLDVAL=""
+3 SET OLDVAL=$$GET^XPAR("SYS^PKG","ORHEPC ABNORMAL START",1,"I")
+4 DO MAIN
+5 IF $LENGTH(OLDVAL)
DO EN^XPAR("SYS","ORHEPC ABNORMAL START",1,OLDVAL)
+6 DO UDABS
+7 DO UDRPTS
+8 ;rebuild ARS xref this version
DO QUE
+9 QUIT
+10 ;
MAIN ; main (initial) parameter transport routine
+1 KILL ^TMP($JOB,"XPARRSTR")
+2 NEW ENT,IDX,ROOT,REF,VAL,I
+3 SET ROOT=$NAME(^TMP($JOB,"XPARRSTR"))
SET ROOT=$EXTRACT(ROOT,1,$LENGTH(ROOT)-1)_","
LOAD ; load data into ^TMP (expects ROOT to be defined)
+1 SET I=1
FOR
SET REF=$TEXT(DATA+I)
IF REF=""
QUIT
SET VAL=$TEXT(DATA+I+1)
Begin DoDot:1
+2 SET I=I+2
SET REF=$PIECE(REF,";",3,999)
SET VAL=$PIECE(VAL,";",3,999)
+3 SET @(ROOT_REF)=VAL
End DoDot:1
+4 QUIT
XX2 SET IDX=0
SET ENT="PKG."_"ORDER ENTRY/RESULTS REPORTING"
+1 FOR
SET IDX=$ORDER(^TMP($JOB,"XPARRSTR",IDX))
IF 'IDX
QUIT
Begin DoDot:1
+2 NEW PAR,INST,VAL,ERR
+3 SET PAR=$PIECE(^TMP($JOB,"XPARRSTR",IDX,"KEY"),U)
SET INST=$PIECE(^("KEY"),U,2)
+4 MERGE VAL=^TMP($JOB,"XPARRSTR",IDX,"VAL")
+5 DO EN^XPAR(ENT,PAR,INST,.VAL,.ERR)
End DoDot:1
+6 KILL ^TMP($JOB,"XPARRSTR")
+7 QUIT
+8 ;
UDABS ;Update abnormal result start date PKG level to installation date
+1 ;update date range in abnormal result report
+2 DO EN^XPAR("PKG","ORHEPC ABNORMAL START",1,$$DT^XLFDT())
+3 NEW DRANGEID,ABSID,STDT,IX,SD,TD,TXTC,DIFF
+4 SET (IX,ABSID,STDT,SD,TX,JX,DIFF)=0
SET TXTC=""
+5 SET ABSID=$ORDER(^ORD(102.21,"B","RPT ABNORMAL RESULTS",0))
+6 SET DRANGEID=$ORDER(^ORD(102.21,"B","CTP SEARCH DATE RANGE",0))
+7 SET STDT=$$GET^XPAR("SYS^PKG","ORHEPC ABNORMAL START",1,"I")
+8 SET TD=$$DT^XLFDT()
+9 SET DIFF=$$FMDIFF^XLFDT(STDT,TD,1)
+10 SET DIFF=+$FNUMBER(DIFF,"T")
+11 IF DIFF>184
SET STDT="T-184"
+12 SET SD=$$FMTE^XLFDT(STDT)
+13 SET TD=$$FMTE^XLFDT(TD)
+14 SET TXTC="from "_SD_" through "_TD
+15 FOR
SET IX=$ORDER(^ORD(102.21,ABSID,1,IX))
IF ('IX)!JX
QUIT
Begin DoDot:1
+16 IF $PIECE(^ORD(102.21,ABSID,1,IX,0),U,2)=DRANGEID
Begin DoDot:2
+17 SET $PIECE(^ORD(102.21,ABSID,1,IX,0),U,4)=TXTC
+18 SET ^ORD(102.21,ABSID,1,IX,1,1,0)=STDT_":T"
+19 KILL ^ORD(102.21,ABSID,1,IX,1,"B")
+20 SET ^ORD(102.21,ABSID,1,IX,1,"B",STDT_":T",1)=""
SET JX=1
QUIT
End DoDot:2
End DoDot:1
+21 QUIT
UDRPTS ;
CSLTRPT ;
+1 NEW IX,JX,RPTID,CTGVL
+2 SET (IX,JX,RPTID,CTGVL)=0
+3 SET RPTID=$ORDER(^ORD(102.21,"B","RPT CONSULT FOLLOW-UP",0))
+4 FOR
SET IX=$ORDER(^ORD(102.21,RPTID,1,IX))
IF ('IX)!JX
QUIT
Begin DoDot:1
+5 IF $PIECE(^(IX,0),U,4)="ALL SERVICES"
Begin DoDot:2
+6 SET CTGVL=$ORDER(^ORD(100.98,"B","CSLT",0))
+7 SET ^ORD(102.21,RPTID,1,IX,1,1,0)=CTGVL
+8 KILL ^ORD(102.21,RPTID,1,IX,1,"B")
SET ^ORD(102.21,RPTID,1,IX,1,"B",CTGVL,1)=""
SET JX=1
End DoDot:2
End DoDot:1
SCHRPT ;
+1 SET (IX,JX,RPTID,CTGVL)=0
+2 SET RPTID=$ORDER(^ORD(102.21,"B","RPT SCHEDULED/DUE ACTIVITY",0))
+3 FOR
SET IX=$ORDER(^ORD(102.21,RPTID,1,IX))
IF ('IX)!JX
QUIT
Begin DoDot:1
+4 IF $PIECE(^(IX,0),U,4)="IMAGING"
Begin DoDot:2
+5 SET CTGVL=$ORDER(^ORD(100.98,"B","IMAGING",0))
+6 SET ^ORD(102.21,RPTID,1,IX,1,1,0)=CTGVL
+7 KILL ^ORD(102.21,RPTID,1,IX,1,"B")
SET ^ORD(102.21,RPTID,1,IX,1,"B",CTGVL,1)=""
End DoDot:2
End DoDot:1
+8 QUIT
QUE ; -- Task xref job
+1 NEW ZTIO,ZTDTH,ZTDESC,ZTRTN,ZTSK,ZTSAVE
+2 SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTDESC="Rebuild ARS xref on Orders file #100"
+3 SET ZTRTN="ARS^ORY153"
DO ^%ZTLOAD
+4 SET X="Task "_$SELECT($GET(ZTSK):"#"_ZTSK,1:"not")_" started to rebuild ^OR(100,""ARS"")."
DO BMES^XPDUTL(X)
+5 QUIT
ARS ; -- Add Patient subscript to xref for test sites
+1 NEW ORFIRST,ORIDX,ORIFN,ORVP,ORDT
+2 SET ORIDX=$QUERY(^OR(100,"ARS"))
IF ORIDX'["ARS"
QUIT
IF $LENGTH(ORIDX,",")>4
QUIT
+3 SET ORFIRST=+$PIECE(ORIDX,",",4)
FOR
SET ORIDX=$QUERY(@ORIDX)
IF ORIDX'?1"^OR(100,""ARS"",".E
QUIT
SET ORIFN=+$PIECE(ORIDX,",",4)
IF ORIFN<ORFIRST
SET ORFIRST=ORIFN
+4 KILL ^OR(100,"ARS")
SET ORIFN=ORFIRST-.1
+5 FOR
SET ORIFN=$ORDER(^OR(100,ORIFN))
IF ORIFN<1
QUIT
Begin DoDot:1
+6 SET ORDT=+$GET(^OR(100,ORIFN,7))
IF ORDT<1
QUIT
SET ORVP=$PIECE($GET(^(0)),U,2)
+7 SET ^OR(100,"ARS",ORVP,9999999-ORDT,ORIFN)=""
End DoDot:1
+8 QUIT
DATA ; parameter data
+1 ;;12848,"KEY")
+2 ;;ORHEPC ABNORMAL START^1
+3 ;;12848,"VAL")
+4 ;;FEB 14, 2003
