VPRSDAHX.m

VPRSDAHX ;SLC/MKB -- SDA Hx utilities ;7/29/22  14:11

 ;;1.0;VIRTUAL PATIENT RECORD;**30**;Sep 01, 2011;Build 9

 ;;Per VHA Directive 6402, this routine should not be modified.

 ;

 ; External References          DBIA#

 ; -------------------          -----

 ; ^AUPNVSIT                     2028

 ; ^AUTTHF                       4295

 ; ^PXRMINDX                     4290

 ; PXPXRM                        4250

 ; WVRPCVPR, ^TMP("WVPREGST"     7199

 ;

 ;

 ; Queries called from GET^DDE, returns DLIST(#)=ien

 ; Expects context variables DFN, DSTRT, DSTOP, DMAX

 ;

HFM ; -- get V Health Factors, for Family History

 N ITEM,DATE,DA,X,VPRN S VPRN=0

 S ITEM=0 F  S ITEM=$O(^PXRMINDX(9000010.23,"PI",+$G(DFN),ITEM)) Q:ITEM<1  D  Q:VPRN'<DMAX

 . S X=$P($G(^AUTTHF(+ITEM,0)),U) I X'["FAMILY HISTORY",X'["FAMILY HX" Q

 . S DATE=DSTRT F  S DATE=$O(^PXRMINDX(9000010.23,"PI",+$G(DFN),ITEM,DATE)) Q:DATE<1!(DATE>DSTOP)  D  Q:VPRN'<DMAX

 .. S DA=0 F  S DA=$O(^PXRMINDX(9000010.23,"PI",+$G(DFN),ITEM,DATE,DA)) Q:DA<1  S VPRN=VPRN+1,DLIST(VPRN)=DA_U_ITEM Q:VPRN'<DMAX

 Q

 ;

HFS ; -- get V Health Factors, for Social History

 N ITEM,DATE,DA,VPRN S VPRN=0

 S ITEM=0 F  S ITEM=$O(^PXRMINDX(9000010.23,"PI",+$G(DFN),ITEM)) Q:ITEM<1  I $$SOCHIST(ITEM) D  Q:VPRN'<DMAX

 . S DATE=DSTRT F  S DATE=$O(^PXRMINDX(9000010.23,"PI",+$G(DFN),ITEM,DATE)) Q:DATE<1!(DATE>DSTOP)  D  Q:VPRN'<DMAX

 .. S DA=0 F  S DA=$O(^PXRMINDX(9000010.23,"PI",+$G(DFN),ITEM,DATE,DA)) Q:DA<1  S VPRN=VPRN+1,DLIST(VPRN)=DA_U_ITEM Q:VPRN'<DMAX

 Q

SOCHIST(IEN) ; -- find social history factors

 N X S X=$P($G(^AUTTHF(+IEN,0)),U)

 I (X["TOBACCO")!(X["SMOK") Q 1

 ;I (X["LIVES")!(X["LIVING") Q 1

 ;I (X["RELIGIO")!(X["SPIRIT") Q 1

 Q 0

 ;

 ;

HF1 ; -- get info for single HF record [ID Action]

 ; Expects/updates DIEN = #9000010.23 ien

 ;       Returns VPRVST = #9000010 ien

 ;              VPRVST0 = Visit zero node

 ;                VPRHF array

 K VPRHF D:$$ZERO^VPRENC("HF",+DIEN) VHF^PXPXRM(+DIEN,.VPRHF)

 S VPRVST=+$G(VPRHF("VISIT")),VPRVST0=$G(^AUPNVSIT(+VPRVST,0))

 S VPRHF=DIEN,DIEN=+DIEN

 Q

 ;

WVPLQ ; -- Women's Health Pregnancy Log [Query]

 ; Query called from GET^DDE, returns DLIST(1)=DFN if data

 ; Expects context variables DFN, DSTRT, DSTOP, DMAX

 ;

 K ^TMP("WVPREGST",$J)

 D BASELINE^WVRPCVPR(DFN)

 S:$D(^TMP("WVPREGST",$J,"BASELINE")) DLIST(1)=DFN

 ;S:$G(^TMP("WVPREGST",$J,"BASELINE","TO TIME"))'<$$FMADD^XLFDT(DT,-14) DLIST(1)=DFN

 Q

 ;

WVPL1(IEN) ; -- set up pregnancy API array (IEN will be DFN)

 ; Returns VPRPREG array to entity

 I $G(IEN)<1 S DDEOUT=1 Q

 D:'$D(^TMP("WVPREGST",$J,"BASELINE")) BASELINE^WVRPCVPR(IEN)

 I '$D(^TMP("WVPREGST",$J,"BASELINE")) S DDEOUT=1 Q

 M VPRPREG=^TMP("WVPREGST",$J,"BASELINE")

 S DFN=IEN,IEN=$G(^TMP("WVPREGST",$J,"BASELINE","EXTERNAL ID"))

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---VPRSDAHX   2809     printed  Feb 19, 2025@00:12:19                                                                                                                                                                                                    Page 2

VPRSDAHX  ;SLC/MKB -- SDA Hx utilities ;7/29/22  14:11

 +1       ;;1.0;VIRTUAL PATIENT RECORD;**30**;Sep 01, 2011;Build 9

 +2       ;;Per VHA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ; External References          DBIA#

 +5       ; -------------------          -----

 +6       ; ^AUPNVSIT                     2028

 +7       ; ^AUTTHF                       4295

 +8       ; ^PXRMINDX                     4290

 +9       ; PXPXRM                        4250

 +10      ; WVRPCVPR, ^TMP("WVPREGST"     7199

 +11      ;

 +12      ;

 +13      ; Queries called from GET^DDE, returns DLIST(#)=ien

 +14      ; Expects context variables DFN, DSTRT, DSTOP, DMAX

 +15      ;

HFM       ; -- get V Health Factors, for Family History

 +1        NEW ITEM,DATE,DA,X,VPRN

           SET VPRN=0

 +2        SET ITEM=0

           FOR 

               SET ITEM=$ORDER(^PXRMINDX(9000010.23,"PI",+$GET(DFN),ITEM))

               if ITEM<1

                   QUIT 

               Begin DoDot:1

 +3                SET X=$PIECE($GET(^AUTTHF(+ITEM,0)),U)

                   IF X'["FAMILY HISTORY"

                       IF X'["FAMILY HX"

                           QUIT 

 +4                SET DATE=DSTRT

                   FOR 

                       SET DATE=$ORDER(^PXRMINDX(9000010.23,"PI",+$GET(DFN),ITEM,DATE))

                       if DATE<1!(DATE>DSTOP)

                           QUIT 

                       Begin DoDot:2

 +5                        SET DA=0

                           FOR 

                               SET DA=$ORDER(^PXRMINDX(9000010.23,"PI",+$GET(DFN),ITEM,DATE,DA))

                               if DA<1

                                   QUIT 

                               SET VPRN=VPRN+1

                               SET DLIST(VPRN)=DA_U_ITEM

                               if VPRN'<DMAX

                                   QUIT 

                       End DoDot:2

                       if VPRN'<DMAX

                           QUIT 

               End DoDot:1

               if VPRN'<DMAX

                   QUIT 

 +6        QUIT 

 +7       ;

HFS       ; -- get V Health Factors, for Social History

 +1        NEW ITEM,DATE,DA,VPRN

           SET VPRN=0

 +2        SET ITEM=0

           FOR 

               SET ITEM=$ORDER(^PXRMINDX(9000010.23,"PI",+$GET(DFN),ITEM))

               if ITEM<1

                   QUIT 

               IF $$SOCHIST(ITEM)

                   Begin DoDot:1

 +3                    SET DATE=DSTRT

                       FOR 

                           SET DATE=$ORDER(^PXRMINDX(9000010.23,"PI",+$GET(DFN),ITEM,DATE))

                           if DATE<1!(DATE>DSTOP)

                               QUIT 

                           Begin DoDot:2

 +4                            SET DA=0

                               FOR 

                                   SET DA=$ORDER(^PXRMINDX(9000010.23,"PI",+$GET(DFN),ITEM,DATE,DA))

                                   if DA<1

                                       QUIT 

                                   SET VPRN=VPRN+1

                                   SET DLIST(VPRN)=DA_U_ITEM

                                   if VPRN'<DMAX

                                       QUIT 

                           End DoDot:2

                           if VPRN'<DMAX

                               QUIT 

                   End DoDot:1

                   if VPRN'<DMAX

                       QUIT 

 +5        QUIT 

SOCHIST(IEN) ; -- find social history factors

 +1        NEW X

           SET X=$PIECE($GET(^AUTTHF(+IEN,0)),U)

 +2        IF (X["TOBACCO")!(X["SMOK")

               QUIT 1

 +3       ;I (X["LIVES")!(X["LIVING") Q 1

 +4       ;I (X["RELIGIO")!(X["SPIRIT") Q 1

 +5        QUIT 0

 +6       ;

 +7       ;

HF1       ; -- get info for single HF record [ID Action]

 +1       ; Expects/updates DIEN = #9000010.23 ien

 +2       ;       Returns VPRVST = #9000010 ien

 +3       ;              VPRVST0 = Visit zero node

 +4       ;                VPRHF array

 +5        KILL VPRHF

           if $$ZERO^VPRENC("HF",+DIEN)

               DO VHF^PXPXRM(+DIEN,.VPRHF)

 +6        SET VPRVST=+$GET(VPRHF("VISIT"))

           SET VPRVST0=$GET(^AUPNVSIT(+VPRVST,0))

 +7        SET VPRHF=DIEN

           SET DIEN=+DIEN

 +8        QUIT 

 +9       ;

WVPLQ     ; -- Women's Health Pregnancy Log [Query]

 +1       ; Query called from GET^DDE, returns DLIST(1)=DFN if data

 +2       ; Expects context variables DFN, DSTRT, DSTOP, DMAX

 +3       ;

 +4        KILL ^TMP("WVPREGST",$JOB)

 +5        DO BASELINE^WVRPCVPR(DFN)

 +6        if $DATA(^TMP("WVPREGST",$JOB,"BASELINE"))

               SET DLIST(1)=DFN

 +7       ;S:$G(^TMP("WVPREGST",$J,"BASELINE","TO TIME"))'<$$FMADD^XLFDT(DT,-14) DLIST(1)=DFN

 +8        QUIT 

 +9       ;

WVPL1(IEN) ; -- set up pregnancy API array (IEN will be DFN)

 +1       ; Returns VPRPREG array to entity

 +2        IF $GET(IEN)<1

               SET DDEOUT=1

               QUIT 

 +3        if '$DATA(^TMP("WVPREGST",$JOB,"BASELINE"))

               DO BASELINE^WVRPCVPR(IEN)

 +4        IF '$DATA(^TMP("WVPREGST",$JOB,"BASELINE"))

               SET DDEOUT=1

               QUIT 

 +5        MERGE VPRPREG=^TMP("WVPREGST",$JOB,"BASELINE")

 +6        SET DFN=IEN

           SET IEN=$GET(^TMP("WVPREGST",$JOB,"BASELINE","EXTERNAL ID"))

 +7        QUIT