ORDV06C.m

ORDV06C ;ISP/RFR - OE/RR REPORT EXTRACTS ;08/22/2017  13:39

 ;;3.0;ORDER ENTRY RESULTS REPORTING;**377**;Dec 17, 1997;Build 582

 Q

RXHIRISK(ROOT,ORDFN,OREXT,ORALPHA,OROMEGA,ORDTRANG,ORREMOTE,ORMAX,ISFHIE) ;Medications with

 ;Reproductive Risk Report

 Q:'$L(OREXT)

 N GO

 S GO=$P(OREXT,";",7)_U_$P(OREXT,";",8)

 Q:'$L($T(@GO))

 D FORMAT

 Q

GETDATA ;RETRIEVE ALL NECESSARY DATA FOR REPORT

 N ORBEG,OREND,ORREMIND,INDEX,PARAM,RETURN,OCINAME,ORIEN,NODE

 K ^TMP("ORPS",$J)

 S ORBEG=$S($G(ORALPHA):ORALPHA,1:$$DT^ORWPS("T")),OREND=$S($G(OROMEGA)>0:OROMEGA,1:$$DT^ORWPS("T"))

 S ORREMIND="VA-WH POTENTIALLY UNSAFE MEDICATIONS REPORT - COHORT",ORREMIND("PRINT")="WH POTENTIALLY UNSAFE MEDS REPORT"

 D MAINDF^PXRM(DFN,ORREMIND,0,ORBEG)

 S ORREMIND("IEN")=+$O(^TMP("PXRHM",$J,0))

 I $P($G(^TMP("PXRHM",$J,ORREMIND("IEN"),ORREMIND("PRINT"))),U)'="DUE NOW" G GEXIT

 S PARAM("SUB")="ORWHRMR",PARAM("DFN")=DFN

 S PARAM("ROC DISPLAY GROUPS","PHARMACY")="",NODE="GROUPS"

 I '(($P(ORBEG,".")=$P(OREND,"."))&($P(ORBEG,".")=$$DT^ORWPS("T"))) D

 .S PARAM("ROC","VA-WH HIRISK IMAGING AGENTS GROUP")="",PARAM("ROC","VA-WH HIRISK MEDICATIONS (EXTREME RISK) GROUP")=""

 .S PARAM("ROC","VA-WH HIRISK MEDICATIONS (LACTATION LEVEL 1) GROUP")="",PARAM("ROC","VA-WH HIRISK MEDICATIONS (LACTATION LEVEL 2) GROUP")=""

 .S PARAM("ROC","VA-WH HIRISK MEDICATIONS (MOD/HIGH RISK DURING PREGNANCY) GROUP")=""

 .S PARAM("ROC RETURN TYPE","GROUPS")="",PARAM("ROC ORDERED WITHIN")=""

 .S PARAM("ROC STATUS","*")=""

 .S PARAM("ROC DISPLAY GROUPS","PHARMACY","START")=ORBEG,PARAM("ROC DISPLAY GROUPS","PHARMACY","STOP")=OREND

 I $P(ORBEG,".")=$P(OREND,"."),$P(ORBEG,".")=$$DT^ORWPS("T") D

 .S PARAM("ROC","ALL")="" ;,PARAM("ROC EVAL DATES")=DT

 .S PARAM("ROC STATUS","HOLD")="",PARAM("ROC STATUS","FLAGGED")="",PARAM("ROC STATUS","PENDING")=""

 .S PARAM("ROC STATUS","ACTIVE")="",PARAM("ROC STATUS","DELAYED")="",PARAM("ROC STATUS","RENEWED")=""

 .S PARAM("ROC RETURN TYPE","GROUPS")="",PARAM("ROC RETURN TYPE","RULES")=""

 D EN^PXRMGEV(.RETURN,.PARAM)

 I $P(@RETURN@(0),U)<1 G GEXIT

 S ORIEN=0 F  S ORIEN=$O(^TMP($J,"ORWHRMR",ORIEN)) Q:'+ORIEN  D

 .N PSIFN

 .S PSIFN=$G(^OR(100,ORIEN,4)) Q:'+PSIFN

 .S INDEX=1+$G(INDEX),OCINAME=""

 .F  S OCINAME=$O(^TMP($J,"ORWHRMR",ORIEN,NODE,OCINAME)) Q:OCINAME=""  I $E(OCINAME,1,13)="VA-WH HIRISK " D

 ..I $D(PARAM("ROC RETURN TYPE","RULES")),'$D(^TMP($J,"ORWHRMR",ORIEN,"RULES")) Q

 ..I '$D(^TMP("ORPS",$J,INDEX)) D

 ...N TYPE,NODE,TO

 ...S TYPE=$P($G(^OR(100,ORIEN,0)),U,12),TO=$P($G(^ORD(100.98,+$P($G(^OR(100,ORIEN,0)),U,11),0)),U)

 ...I TYPE="O",TO["CLINIC" S TYPE="I"

 ...S:TYPE="O" PSIFN=$TR(PSIFN,"S","P")_$S(PSIFN?1.N:"R",1:"")

 ...S PSIFN=PSIFN_";"_TYPE

 ...D OEL^PSOORRL(DFN,PSIFN)  ;DBIA 2400

 ...I '$D(^TMP("PS",$J)) Q

 ...S TYPE=$S(TYPE="O":"OP",1:"UD")

 ...I TYPE="OP",PSIFN["N" S TYPE="NV"

 ...I ($O(^TMP("PS",$J,"A",0))>0)!($O(^TMP("PS",$J,"B",0))>0) S TYPE="IV"

 ...S NODE=$G(^TMP("PS",$J,0))

 ...S ^TMP("ORPS",$J,INDEX)=TYPE_U_PSIFN_U_$P(NODE,U)_U_$P(NODE,U,3)_U_$P(NODE,U,5,6)_U_$P(NODE,U,12)

 ...S:TYPE="NV" $P(^TMP("ORPS",$J,INDEX),U,5)=$P($G(^OR(100,ORIEN,0)),U,8)

 ...I $P(^TMP("ORPS",$J,INDEX),U,6)="PENDING" S $P(^(INDEX),U,5)=""

 ..Q:'$D(^TMP("ORPS",$J,INDEX))

 ..I OCINAME'["(LACT" S $P(^TMP("ORPS",$J,INDEX),U,8)="*"

 ..I OCINAME["(LACT" S $P(^TMP("ORPS",$J,INDEX),U,9)="*"

GEXIT ;CLEAN-UP FOR GETDATA

 K ^TMP("PXRHM",$J),^TMP("PS",$J),^TMP($J,"ORWHRMR")

 Q

FORMAT ;FORMAT DATA FOR RETURN TO CPRS

 K ^TMP("ORPS",$J)

 D @GO

 N ORSITE,J,RT,X,ORITM

 S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)

 S ORITM=0 F  S ORITM=$O(^TMP("ORPS",$J,ORITM)) Q:'+ORITM  D

 .S ^TMP("ORDATA",$J,ORITM,"WP",1)="1^"_ORSITE ;Station ID

 .S ^TMP("ORDATA",$J,ORITM,"WP",2)="2^"_$P(^TMP("ORPS",$J,ORITM),U,3) ;Medication Name

 .S ^TMP("ORDATA",$J,ORITM,"WP",3)="3^"_$P(^TMP("ORPS",$J,ORITM),U,6) ;Status

 .S ^TMP("ORDATA",$J,ORITM,"WP",4)="4^"_$S($P($P(^TMP("ORPS",$J,ORITM),U,2),";",2)="I":"IN",1:"OUT") ;In/OutPatient

 .S ^TMP("ORDATA",$J,ORITM,"WP",5)="5^"_$S($P(^TMP("ORPS",$J,ORITM),U)="NV":"NonVAMed",1:"RX") ;Type: RX or NonVA Med

 .S ^TMP("ORDATA",$J,ORITM,"WP",6)="6^"_$P(^TMP("ORPS",$J,ORITM),U,8) ;Teratogenic

 .S ^TMP("ORDATA",$J,ORITM,"WP",7)="7^"_$P(^TMP("ORPS",$J,ORITM),U,9) ;Lactation

 .S ^TMP("ORDATA",$J,ORITM,"WP",8)="8^"_$$DATE^ORDVU($P(^TMP("ORPS",$J,ORITM),U,5)) ;Start Date

 .S ^TMP("ORDATA",$J,ORITM,"WP",9)="9^"_$$DATE^ORDVU($P(^TMP("ORPS",$J,ORITM),U,4)) ;Stop Date

 .S ^TMP("ORDATA",$J,ORITM,"WP",10)="10^"_$$DATE^ORDVU($P(^TMP("ORPS",$J,ORITM),U,7)) ;Last Fill Date

 .D DETAIL^ORWPS(.RT,DFN,$P(^TMP("ORPS",$J,ORITM),U,2))

 .S J=0 F  S J=$O(^TMP("ORXPND",$J,J)) Q:'J  S X=^(J,0),^TMP("ORDATA",$J,ORITM,"WP",11,J)="11^"_X ;Details from Order

 .K ^TMP("ORXPND",$J)

 .S ^TMP("ORDATA",$J,ORITM,"WP",12)="12^[+] " ;flag for detail

 K ^TMP("ORPS",$J)

 S ROOT=$NA(^TMP("ORDATA",$J))

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ORDV06C   4915     printed  Mar 13, 2025@21:35:14                                                                                                                                                                                                     Page 2

ORDV06C   ;ISP/RFR - OE/RR REPORT EXTRACTS ;08/22/2017  13:39

 +1       ;;3.0;ORDER ENTRY RESULTS REPORTING;**377**;Dec 17, 1997;Build 582

 +2        QUIT 

RXHIRISK(ROOT,ORDFN,OREXT,ORALPHA,OROMEGA,ORDTRANG,ORREMOTE,ORMAX,ISFHIE) ;Medications with

 +1       ;Reproductive Risk Report

 +2        if '$LENGTH(OREXT)

               QUIT 

 +3        NEW GO

 +4        SET GO=$PIECE(OREXT,";",7)_U_$PIECE(OREXT,";",8)

 +5        if '$LENGTH($TEXT(@GO))

               QUIT 

 +6        DO FORMAT

 +7        QUIT 

GETDATA   ;RETRIEVE ALL NECESSARY DATA FOR REPORT

 +1        NEW ORBEG,OREND,ORREMIND,INDEX,PARAM,RETURN,OCINAME,ORIEN,NODE

 +2        KILL ^TMP("ORPS",$JOB)

 +3        SET ORBEG=$SELECT($GET(ORALPHA):ORALPHA,1:$$DT^ORWPS("T"))

           SET OREND=$SELECT($GET(OROMEGA)>0:OROMEGA,1:$$DT^ORWPS("T"))

 +4        SET ORREMIND="VA-WH POTENTIALLY UNSAFE MEDICATIONS REPORT - COHORT"

           SET ORREMIND("PRINT")="WH POTENTIALLY UNSAFE MEDS REPORT"

 +5        DO MAINDF^PXRM(DFN,ORREMIND,0,ORBEG)

 +6        SET ORREMIND("IEN")=+$ORDER(^TMP("PXRHM",$JOB,0))

 +7        IF $PIECE($GET(^TMP("PXRHM",$JOB,ORREMIND("IEN"),ORREMIND("PRINT"))),U)'="DUE NOW"

               GOTO GEXIT

 +8        SET PARAM("SUB")="ORWHRMR"

           SET PARAM("DFN")=DFN

 +9        SET PARAM("ROC DISPLAY GROUPS","PHARMACY")=""

           SET NODE="GROUPS"

 +10       IF '(($PIECE(ORBEG,".")=$PIECE(OREND,"."))&($PIECE(ORBEG,".")=$$DT^ORWPS("T")))

               Begin DoDot:1

 +11               SET PARAM("ROC","VA-WH HIRISK IMAGING AGENTS GROUP")=""

                   SET PARAM("ROC","VA-WH HIRISK MEDICATIONS (EXTREME RISK) GROUP")=""

 +12               SET PARAM("ROC","VA-WH HIRISK MEDICATIONS (LACTATION LEVEL 1) GROUP")=""

                   SET PARAM("ROC","VA-WH HIRISK MEDICATIONS (LACTATION LEVEL 2) GROUP")=""

 +13               SET PARAM("ROC","VA-WH HIRISK MEDICATIONS (MOD/HIGH RISK DURING PREGNANCY) GROUP")=""

 +14               SET PARAM("ROC RETURN TYPE","GROUPS")=""

                   SET PARAM("ROC ORDERED WITHIN")=""

 +15               SET PARAM("ROC STATUS","*")=""

 +16               SET PARAM("ROC DISPLAY GROUPS","PHARMACY","START")=ORBEG

                   SET PARAM("ROC DISPLAY GROUPS","PHARMACY","STOP")=OREND

               End DoDot:1

 +17       IF $PIECE(ORBEG,".")=$PIECE(OREND,".")

               IF $PIECE(ORBEG,".")=$$DT^ORWPS("T")

                   Begin DoDot:1

 +18      ;,PARAM("ROC EVAL DATES")=DT

                       SET PARAM("ROC","ALL")=""

 +19                   SET PARAM("ROC STATUS","HOLD")=""

                       SET PARAM("ROC STATUS","FLAGGED")=""

                       SET PARAM("ROC STATUS","PENDING")=""

 +20                   SET PARAM("ROC STATUS","ACTIVE")=""

                       SET PARAM("ROC STATUS","DELAYED")=""

                       SET PARAM("ROC STATUS","RENEWED")=""

 +21                   SET PARAM("ROC RETURN TYPE","GROUPS")=""

                       SET PARAM("ROC RETURN TYPE","RULES")=""

                   End DoDot:1

 +22       DO EN^PXRMGEV(.RETURN,.PARAM)

 +23       IF $PIECE(@RETURN@(0),U)<1

               GOTO GEXIT

 +24       SET ORIEN=0

           FOR 

               SET ORIEN=$ORDER(^TMP($JOB,"ORWHRMR",ORIEN))

               if '+ORIEN

                   QUIT 

               Begin DoDot:1

 +25               NEW PSIFN

 +26               SET PSIFN=$GET(^OR(100,ORIEN,4))

                   if '+PSIFN

                       QUIT 

 +27               SET INDEX=1+$GET(INDEX)

                   SET OCINAME=""

 +28               FOR 

                       SET OCINAME=$ORDER(^TMP($JOB,"ORWHRMR",ORIEN,NODE,OCINAME))

                       if OCINAME=""

                           QUIT 

                       IF $EXTRACT(OCINAME,1,13)="VA-WH HIRISK "

                           Begin DoDot:2

 +29                           IF $DATA(PARAM("ROC RETURN TYPE","RULES"))

                                   IF '$DATA(^TMP($JOB,"ORWHRMR",ORIEN,"RULES"))

                                       QUIT 

 +30                           IF '$DATA(^TMP("ORPS",$JOB,INDEX))

                                   Begin DoDot:3

 +31                                   NEW TYPE,NODE,TO

 +32                                   SET TYPE=$PIECE($GET(^OR(100,ORIEN,0)),U,12)

                                       SET TO=$PIECE($GET(^ORD(100.98,+$PIECE($GET(^OR(100,ORIEN,0)),U,11),0)),U)

 +33                                   IF TYPE="O"

                                           IF TO["CLINIC"

                                               SET TYPE="I"

 +34                                   if TYPE="O"

                                           SET PSIFN=$TRANSLATE(PSIFN,"S","P")_$SELECT(PSIFN?1.N:"R",1:"")

 +35                                   SET PSIFN=PSIFN_";"_TYPE

 +36      ;DBIA 2400

                                       DO OEL^PSOORRL(DFN,PSIFN)

 +37                                   IF '$DATA(^TMP("PS",$JOB))

                                           QUIT 

 +38                                   SET TYPE=$SELECT(TYPE="O":"OP",1:"UD")

 +39                                   IF TYPE="OP"

                                           IF PSIFN["N"

                                               SET TYPE="NV"

 +40                                   IF ($ORDER(^TMP("PS",$JOB,"A",0))>0)!($ORDER(^TMP("PS",$JOB,"B",0))>0)

                                           SET TYPE="IV"

 +41                                   SET NODE=$GET(^TMP("PS",$JOB,0))

 +42                                   SET ^TMP("ORPS",$JOB,INDEX)=TYPE_U_PSIFN_U_$PIECE(NODE,U)_U_$PIECE(NODE,U,3)_U_$PIECE(NODE,U,5,6)_U_$PIECE(NODE,U,12)

 +43                                   if TYPE="NV"

                                           SET $PIECE(^TMP("ORPS",$JOB,INDEX),U,5)=$PIECE($GET(^OR(100,ORIEN,0)),U,8)

 +44                                   IF $PIECE(^TMP("ORPS",$JOB,INDEX),U,6)="PENDING"

                                           SET $PIECE(^(INDEX),U,5)=""

                                   End DoDot:3

 +45                           if '$DATA(^TMP("ORPS",$JOB,INDEX))

                                   QUIT 

 +46                           IF OCINAME'["(LACT"

                                   SET $PIECE(^TMP("ORPS",$JOB,INDEX),U,8)="*"

 +47                           IF OCINAME["(LACT"

                                   SET $PIECE(^TMP("ORPS",$JOB,INDEX),U,9)="*"

                           End DoDot:2

               End DoDot:1

GEXIT     ;CLEAN-UP FOR GETDATA

 +1        KILL ^TMP("PXRHM",$JOB),^TMP("PS",$JOB),^TMP($JOB,"ORWHRMR")

 +2        QUIT 

FORMAT    ;FORMAT DATA FOR RETURN TO CPRS

 +1        KILL ^TMP("ORPS",$JOB)

 +2        DO @GO

 +3        NEW ORSITE,J,RT,X,ORITM

 +4        SET ORSITE=$$SITE^VASITE

           SET ORSITE=$PIECE(ORSITE,"^",2)_";"_$PIECE(ORSITE,"^",3)

 +5        SET ORITM=0

           FOR 

               SET ORITM=$ORDER(^TMP("ORPS",$JOB,ORITM))

               if '+ORITM

                   QUIT 

               Begin DoDot:1

 +6       ;Station ID

                   SET ^TMP("ORDATA",$JOB,ORITM,"WP",1)="1^"_ORSITE

 +7       ;Medication Name

                   SET ^TMP("ORDATA",$JOB,ORITM,"WP",2)="2^"_$PIECE(^TMP("ORPS",$JOB,ORITM),U,3)

 +8       ;Status

                   SET ^TMP("ORDATA",$JOB,ORITM,"WP",3)="3^"_$PIECE(^TMP("ORPS",$JOB,ORITM),U,6)

 +9       ;In/OutPatient

                   SET ^TMP("ORDATA",$JOB,ORITM,"WP",4)="4^"_$SELECT($PIECE($PIECE(^TMP("ORPS",$JOB,ORITM),U,2),";",2)="I":"IN",1:"OUT")

 +10      ;Type: RX or NonVA Med

                   SET ^TMP("ORDATA",$JOB,ORITM,"WP",5)="5^"_$SELECT($PIECE(^TMP("ORPS",$JOB,ORITM),U)="NV":"NonVAMed",1:"RX")

 +11      ;Teratogenic

                   SET ^TMP("ORDATA",$JOB,ORITM,"WP",6)="6^"_$PIECE(^TMP("ORPS",$JOB,ORITM),U,8)

 +12      ;Lactation

                   SET ^TMP("ORDATA",$JOB,ORITM,"WP",7)="7^"_$PIECE(^TMP("ORPS",$JOB,ORITM),U,9)

 +13      ;Start Date

                   SET ^TMP("ORDATA",$JOB,ORITM,"WP",8)="8^"_$$DATE^ORDVU($PIECE(^TMP("ORPS",$JOB,ORITM),U,5))

 +14      ;Stop Date

                   SET ^TMP("ORDATA",$JOB,ORITM,"WP",9)="9^"_$$DATE^ORDVU($PIECE(^TMP("ORPS",$JOB,ORITM),U,4))

 +15      ;Last Fill Date

                   SET ^TMP("ORDATA",$JOB,ORITM,"WP",10)="10^"_$$DATE^ORDVU($PIECE(^TMP("ORPS",$JOB,ORITM),U,7))

 +16               DO DETAIL^ORWPS(.RT,DFN,$PIECE(^TMP("ORPS",$JOB,ORITM),U,2))

 +17      ;Details from Order

                   SET J=0

                   FOR 

                       SET J=$ORDER(^TMP("ORXPND",$JOB,J))

                       if 'J

                           QUIT 

                       SET X=^(J,0)

                       SET ^TMP("ORDATA",$JOB,ORITM,"WP",11,J)="11^"_X

 +18               KILL ^TMP("ORXPND",$JOB)

 +19      ;flag for detail

                   SET ^TMP("ORDATA",$JOB,ORITM,"WP",12)="12^[+] "

               End DoDot:1

 +20       KILL ^TMP("ORPS",$JOB)

 +21       SET ROOT=$NAME(^TMP("ORDATA",$JOB))

 +22       QUIT