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