ORY153.m

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ORY153   3606     printed  Feb 19, 2025@00:05:19                                                                                                                                                                                                      Page 2

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