Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VPRHSX1

VPRHSX1.m

Go to the documentation of this file.
  1. VPRHSX1 ;SLC/MKB -- HS Mgt Options cont ;09/18/18 4:36pm
  1. ;;1.0;VIRTUAL PATIENT RECORD;**25,27,31**;Sep 01, 2011;Build 3
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; External References DBIA#
  1. ; ------------------- -----
  1. ; ^DDE 7014
  1. ; ^DPT 10035
  1. ; ^GMR(120.86 3449
  1. ; DIQ 2056
  1. ; DIR 10026
  1. ; MPIF001 2701
  1. ; ORQ12 5704
  1. ; VADPT 3744
  1. ; XLFDT 10103
  1. ; XUPROD 4440
  1. ;
  1. GET ; -- Add patient/container/record to GET list [VPR HS PUSH]
  1. N DFN,ICN,X
  1. I '$P($G(^VPR(1,0)),U,2) W !,"WARNING: Data Monitoring is currently disabled!",!
  1. ;
  1. W ! S DFN=+$$PATIENT^VPRHST Q:DFN<1
  1. I '$$SUBS^VPRHS(DFN) D Q
  1. . W !,$C(7),"WARNING: This patient is not currently in the Edge Cache Repository (ECR)!",!
  1. . S ICN=$$ICN(DFN) I ICN<0 W !,$P(ICN,U,2),!,"Cannot add to ECR",! Q
  1. . I $G(^VPR(1,2,DFN,"ANEW")) W !,"This patient already has a request for subscription.",! Q
  1. . Q:'$$CONT D NEW^VPRHS(DFN,ICN)
  1. . S X=$G(^VPR(1,2,DFN,"ANEW"))
  1. . W !," ... request "_$S(X:"",1:"NOT ")_"added to update queue."
  1. ;
  1. I $$MERGED^VPRHS(DFN) D Q
  1. . S X=$G(^DPT(DFN,-9))
  1. . W !,"Patient is being merged"_$S(X:" into DFN "_X,1:""),!
  1. S ICN=$$GETICN^MPIF001(DFN) I ICN<0 W !,"ICN is required!",! Q
  1. N TYPE,ENT,FN,ACT,VST,DLIST,VPRX,VPRI,VPRN,ID
  1. G1 ;loop for prompting
  1. S TYPE=$$CONTNR^VPRHST,ID="" Q:"^"[TYPE
  1. I $G(^VPR(1,2,DFN,"AVPR",TYPE,"*")) W !,"This patient already has a container update request in the queue!",! G G1
  1. I TYPE="Patient" D G G1
  1. . W !,"Entire container must be updated."
  1. . S ID=DFN_";2"
  1. . D P1^VPRHS,OUT W !
  1. I $$ALL D P1^VPRHS,OUT W ! G G1
  1. ;
  1. ; select source file, record(s)
  1. S ENT=$$ENTITY(TYPE) G:"^"[ENT G1
  1. S FN=$P(ENT,U,3),ACT="U"
  1. D QUERY I '$D(DLIST) W !,"No records available to update.",! G G1
  1. S VPRX=$$SELECT(FN) I "^"[VPRX W ! G G1
  1. F VPRI=1:1 S VPRN=$P(VPRX,",",VPRI) Q:VPRN<1 D
  1. . S ID=$G(DLIST(VPRN))_";"_FN
  1. . D P1^VPRHS,OUT(VPRN)
  1. ;
  1. W ! G G1
  1. Q
  1. ;
  1. ICN(DFN) ; -- return ICN or -1^Message
  1. N ICN,X I $G(DFN)<1 S ICN="-1^INVALID PATIENT" G ICQ
  1. S X=$G(^DPT(DFN,.35)) I X D G ICQ
  1. . S ICN="-1^Patient DIED on "_$$FMTE^XLFDT(X)
  1. I $$TESTPAT^VADPT(DFN),$$PROD^XUPROD S ICN="-1^TEST PATIENT" G ICQ
  1. I $$MERGED^VPRHS(DFN) D G ICQ
  1. . S ICN="-1^Patient is being MERGED",X=$G(^DPT(DFN,-9))
  1. . I X S ICN=ICN_" into DFN "_X
  1. S ICN=$$GETICN^MPIF001(DFN) ;-1^error or ICN
  1. ICQ ;exit
  1. Q ICN
  1. ;
  1. OUT(N) ; -- write message
  1. S:$G(ID)="" ID="*"
  1. N SEQ S SEQ=+$G(^VPR(1,2,DFN,"AVPR",TYPE,ID))
  1. I ID="*" W !,TYPE," container "_$S(SEQ:"",1:" NOT")_" added to update queue." Q
  1. W !,TYPE_" "_$S($G(N):"#"_N,1:"")_$S(SEQ:"",1:" NOT")_" added to update queue."
  1. Q
  1. ;
  1. CONT() ; -- continue?
  1. N X,Y,DIR,DUOUT,DTOUT
  1. S DIR(0)="YA",DIR("B")="NO"
  1. S DIR("A")="Are you sure you want to continue with this patient? "
  1. S DIR("?")="Enter YES to add this patient to the ECR and subscribe to VistA updates, or NO to exit."
  1. D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="^"
  1. Q Y
  1. ;
  1. ENTITY(TYPE) ; -- return array of selected Entity info
  1. N C,X,Y,I,FN S TYPE=$G(TYPE,"ZZZ")
  1. S C=+$O(^VPRC(560.1,"C",TYPE,0))
  1. S X=+$P($G(^VPRC(560.1,C,1,0)),U,4),Y=0
  1. I X<1 W !!,"This container has no source files." G ENTQ
  1. I X=1 S I=+$O(^VPRC(560.1,C,1,0)),Y=+$P($G(^(I,0)),U,2) G ENTQ
  1. ;
  1. W !!,"This container has multiple sources; please select one."
  1. S FN=$$FILE^VPRHST(C) I FN>0 D
  1. . S I=+$O(^VPRC(560.1,C,1,"B",FN,0))
  1. . S Y=+$P($G(^VPRC(560.1,C,1,I,0)),U,2)
  1. ENTQ ;exit
  1. S:Y Y=Y_U_$G(^DDE(Y,0))
  1. Q Y
  1. ;
  1. ALL() ; -- return 1 or 0, for full container (all records) update
  1. N X,Y,DIR,DUOUT,DTOUT
  1. S DIR(0)="YA",DIR("B")="NO"
  1. S DIR("A")="Update the full container? "
  1. S DIR("?")="Enter YES to send all available records in this container to the ECR, or NO to exit."
  1. D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="^"
  1. Q Y
  1. ;
  1. QUERY ; -- execute Query, return DLIST(#)=ID
  1. ; Expects DFN, ENT=ien^name^file#
  1. N DSTRT,DSTOP,DMAX,QRTN
  1. Q:'$G(DFN) S QRTN=$G(^DDE(+ENT,5)) Q:QRTN="" Q:'$L($T(@($P(QRTN,"("))))
  1. S DSTRT=2222222,DSTOP=4444444,DMAX=99999 K DLIST
  1. D @QRTN
  1. Q
  1. ;
  1. SELECT(FNUM) ; -- select ID(s) for update list
  1. N X,Y,DIR
  1. W !!,"Available "_TYPE_"s for "_$P($G(^DPT(DFN,0)),U)_": " D LIST
  1. S DIR(0)="LAO^1:"_$O(DLIST("A"),-1),DIR("A")="Select ITEM(S): "
  1. S DIR("?")="Select the number(s) of the records for updating."
  1. S DIR("??")="^D LIST^VPRHSX"
  1. D ^DIR
  1. Q Y
  1. ;
  1. LIST ; -- ??help for SELECT
  1. N FLDS,LCNT,ID,X,DONE
  1. S (LCNT,DONE)=0,FLDS=$$FIELDS(FNUM)
  1. F S LCNT=$O(DLIST(LCNT)) Q:LCNT<1 D Q:DONE
  1. . S ID=DLIST(LCNT) S:ID["^" ID=$P(ID,U) S:ID["~" ID=$P(ID,"~") ;IEN
  1. . W !,LCNT,?5,$$DATE(FNUM,$P(FLDS,";"),ID)
  1. . W @$S(TYPE="Problem":"?19",TYPE="MemberEnrollment":"?19",1:"?25")
  1. . W $$NAME(FNUM,$P(FLDS,";",2,99),ID)
  1. . Q:LCNT#22 W !,"Press <return> to continue..."
  1. . R X:DTIME I '$T!(X["^") S DONE=1
  1. Q
  1. ;
  1. DATE(FN,FD,DA) ; -- return external date
  1. N RES S RES=$$GET1^DIQ(FN,DA_",",FD)
  1. I $P(RES,":",3) S RES=$P(RES,":",1,2) ;strip seconds
  1. I RES="" S RES="<NO DATE>"
  1. Q RES
  1. ;
  1. NAME(FN,FD,DA) ; -- return name or description
  1. N RES S RES=""
  1. I FN=120.86 S RES=$S('$P($G(^GMR(120.86,DA,0)),U,2):"No ",1:"")_"Known Allergies" Q RES
  1. I FN=100,TYPE="OtherOrder" D Q RES
  1. . N VPRX,ORIGVIEW
  1. . S ORIGVIEW=2 D TEXT^ORQ12(.VPRX,DA)
  1. . S RES=$G(VPRX(1))
  1. . I $L(RES)>50 S RES=$E(RES,1,50)_"..."
  1. N IDX,VPRX,SP S IDX="VPRX",SP=""
  1. D:FD GETS^DIQ(FN,DA_",",FD,"EN",IDX)
  1. F S IDX=$Q(@IDX) Q:IDX'?1"VPRX(".E S RES=RES_SP_@IDX,SP=", "
  1. Q RES
  1. ;
  1. FIELDS(FN,IEN) ; -- DATE;NAME fields to display record
  1. N Y,FLDS S Y=""
  1. I FN=120.5 S Y=".01;.03"
  1. I FN=120.8 S Y="4;.02"
  1. I FN=120.86 S Y="3;1"
  1. I FN=100 S Y="21;.1*"
  1. I FN=9000010 S Y=".01;.07;.22"
  1. I FN[".",$P(FN,".")=9000010 S Y=".03;.01"
  1. ; FN=790.05 S Y=".01;21"
  1. I FN=9000011 S Y=".08;.05"
  1. I FN=783 S Y=".1"
  1. I FN=230 S Y=".01;.03"
  1. I FN=405 S Y=".01;.02"
  1. I FN=2.98 S Y=".001;.01"
  1. I FN=41.1 S Y="2;9;10"
  1. I FN=45 S Y="2;79"
  1. I FN=8925 S Y="1301;.01"
  1. I FN=74 S Y="3;102"
  1. I $P(FN,".")=63 S Y=".01;.06"
  1. I FN=702 S Y=".02;.04"
  1. I FN=130 S Y=".09;26"
  1. I FN=123 S Y="3;1;4"
  1. I FN=26.13 S Y=".06;.02"
  1. I FN=2.312 S Y="8;.18"
  1. Q Y