BQIVFADD ;PRXM/HC/ALA-Add new Vfile entry ; 09 Apr 2007 5:48 PM
;;2.2;ICARE MANAGEMENT SYSTEM;;Jul 28, 2011;Build 37
Q
;
EN(DATA,DFN,VFILE,MORE,VPARMS,EPARMS) ;EP -- BQI ADD NEW VFILE ENTRY
;
;Input
; DFN - Patient's IEN
; VFILE - Vfile add new entry to
; MORE - More entries for the same date
; VPARMS - Visit parameters
; EPARMS - Event parameters
;
NEW UID,II,VFIEN,LIST,BQ,PFIEN,PRFLD,PRVAL,CLN,APCDPAT,CHIEN,PDATA,TBFIL
NEW APCDDATE,APCDTCPT,QUALIF
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BQIVFADD",UID)),MORE=$G(MORE)
K @DATA
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BQIVFADD D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S @DATA@(II)="I00010RESULT"_$C(30)
;
S VFILE=$G(VFILE,"") I VFILE="" S BMXSEC="No Vfile selected" Q
;
; Get the visit parameters
S VPARMS=$G(VPARMS,"")
I VPARMS="" D
. S LIST="",BN=""
. F S BN=$O(VPARMS(BN)) Q:BN="" S LIST=LIST_VPARMS(BN)
. K VPARMS
. S VPARMS=LIST
. K LIST
;
;Get the PCC event parameters
S EPARMS=$G(EPARMS,"")
I EPARMS="" D
. S LIST="",BN=""
. F S BN=$O(EPARMS(BN)) Q:BN="" S LIST=LIST_EPARMS(BN)
. K EPARMS
. S EPARMS=LIST
. K LIST
;
; Parse the visit parameters
K APCDALVR
F BQ=1:1:$L(VPARMS,$C(28)) D
. NEW VFIEN
. S VFIEN=$$FIND1^DIC(90506.3,"","MX","PCC Visit","","","ERROR")
. S PDATA=$P(VPARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I VALUE="" Q
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,"")) Q:PFIEN=""
. I "AD"[$P(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1) S VALUE=$$DATE^BQIUL1(VALUE)
. I $P(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)="C" D
.. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
. S APCDALVR(NAME)=VALUE
S APCDALVR("APCDPAT")=DFN,APCDPAT=DFN
S APCDALVR("APCDANE")="",APCDALVR("AUPNTALK")=""
S APCDALVR("APCDLOC")=$S($G(APCDALVR("APCDLOC"))'="":APCDALVR("APCDLOC"),1:DUZ(2))
S APCDALVR("APCDTYPE")=$G(APCDALVR("APCDTYPE"),"I")
S APCDALVR("APCDCAT")=$G(APCDALVR("APCDCAT"),"E")
S APCDALVR("APCDCLN")=$G(CLN,"")
I $G(MORE)'="" S APCDALVR("APCDAUTO")=1
;
; Create visit and then update other Vfiles
D EN^APCDALV
; Check for error
I '$G(APCDALVR("APCDAFLG")) S VISIT=$G(APCDALVR("APCDVSIT"))
I $G(APCDALVR("APCDAFLG"))=2 S RESULT=-1 G DONE
;
; If there is an outside provider, set it separately
I $G(APCDALVR("APCDTOPR"))'="" D
. S BQIUPD(9000010,VISIT_",",1210)=$G(APCDALVR("APCDTOPR"))
. D FILE^DIE("","BQIUPD","ERROR")
. K BQIUPD
;
; Determine the input template for the event
I VFILE=9000010.01 S VFIEN=$O(^BQI(90506.3,"B","Measurement",""))
E S VFIEN=$$FIND1^DIC(90506.3,"","M",VFILE,"","","ERROR")
S VFILE=$$GET1^DIQ(90506.3,VFIEN_",",.02,"E")
S APCDALVR("APCDATMP")="[APCDALVR "_VFILE_" (ADD)]"
;
; Parse the event parameters
F BQ=1:1:$L(EPARMS,$C(28)) D
. S PDATA=$P(EPARMS,$C(28),BQ) Q:PDATA=""
. S NAME=$P(PDATA,"=",1),VALUE=$P(PDATA,"=",2,99)
. I VALUE="" Q
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
. I "AD"[$P(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1) S VALUE=$$DATE^BQIUL1(VALUE)
. I $P(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)="C" D
.. S CHIEN=$O(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,"")) I CHIEN="" Q
.. S VALUE=$P(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
. S APCDALVR(NAME)=VALUE
. S @NAME=VALUE
. I NAME="VITDTM" S APCDALVR("APCDTCDT")=$G(@NAME)
;
;Check fields for pointers
S PRFLD=""
F S PRFLD=$O(^BQI(90506.3,VFIEN,10,"AC",PRFLD)) Q:PRFLD="" D
. I $G(APCDALVR(PRFLD))="" Q
. S PFIEN=$O(^BQI(90506.3,VFIEN,10,"AC",PRFLD,""))
. S PTYP=$P(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)
. I PTYP'="T" Q
. S PRVAL=APCDALVR(PRFLD)
. I PRFLD="APCDTPRV" Q
. S APCDALVR(PRFLD)="`"_PRVAL
;
; Check for code set versioning
;I VFILE=9000010.18 D
;. I $G(APCDDATE)="" S APCDDATE=$P(^AUPNVSIT(VISIT,0),U,1)\1
;. I $G(APCDTCPT)'="" D CPT^BQIVFVAL(APCDDATE,APCDTCPT)
;. I RESULT=1 S APCDALVR("DIFGLINE")=1
;. I $$PATCH^XPDUTL("BJPC*2.0*1") K APCDALVR("DIFGLINE")
;
; Create V files
D EN^APCDALVR
; Check for error
I '$G(APCDALVR("APCDAFLG")) S RESULT=1
I $G(APCDALVR("APCDAFLG"))=2 S RESULT=-1
;
I $G(QUALIF)'="",VFILE=9000010.01,RESULT=1 S IEN=$G(APCDALVR("APCDADFN")) D QLF
;
; Cleanup
K APCDALVR
;
DONE ;
S II=II+1,@DATA@(II)=RESULT_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $G(II)="" S II=0
I $G(UID)="" S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
I $G(DATA)="" S DATA=$NA(^TMP("BQIVFADD",UID))
S II=II+1,@DATA@(II)=$C(31)
Q
;
QLF ; Update Qualifiers
I $G(^AUPNVMSR(IEN,5,0))="" S ^AUPNVMSR(IEN,5,0)="^9000010.015PA^^"
NEW DIC,DA,X,BJ
S DA(1)=IEN
S DLAYGO=9000010.015,DIC="^AUPNVMSR("_DA(1)_",5,",DIC("P")=DLAYGO,DIC(0)="L"
F BJ=1:1 S X=$P(QUALIF,$C(29),BJ) Q:X="" K DO,DD D FILE^DICN
Q
BQIVFADD ;PRXM/HC/ALA-Add new Vfile entry ; 09 Apr 2007 5:48 PM
+1 ;;2.2;ICARE MANAGEMENT SYSTEM;;Jul 28, 2011;Build 37
+2 QUIT
+3 ;
EN(DATA,DFN,VFILE,MORE,VPARMS,EPARMS) ;EP -- BQI ADD NEW VFILE ENTRY
+1 ;
+2 ;Input
+3 ; DFN - Patient's IEN
+4 ; VFILE - Vfile add new entry to
+5 ; MORE - More entries for the same date
+6 ; VPARMS - Visit parameters
+7 ; EPARMS - Event parameters
+8 ;
+9 NEW UID,II,VFIEN,LIST,BQ,PFIEN,PRFLD,PRVAL,CLN,APCDPAT,CHIEN,PDATA,TBFIL
+10 NEW APCDDATE,APCDTCPT,QUALIF
+11 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+12 SET DATA=$NAME(^TMP("BQIVFADD",UID))
SET MORE=$GET(MORE)
+13 KILL @DATA
+14 SET II=0
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BQIVFADD D UNWIND^%ZTER"
+16 ;
+17 SET @DATA@(II)="I00010RESULT"_$CHAR(30)
+18 ;
+19 SET VFILE=$GET(VFILE,"")
IF VFILE=""
SET BMXSEC="No Vfile selected"
QUIT
+20 ;
+21 ; Get the visit parameters
+22 SET VPARMS=$GET(VPARMS,"")
+23 IF VPARMS=""
Begin DoDot:1
+24 SET LIST=""
SET BN=""
+25 FOR
SET BN=$ORDER(VPARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_VPARMS(BN)
+26 KILL VPARMS
+27 SET VPARMS=LIST
+28 KILL LIST
End DoDot:1
+29 ;
+30 ;Get the PCC event parameters
+31 SET EPARMS=$GET(EPARMS,"")
+32 IF EPARMS=""
Begin DoDot:1
+33 SET LIST=""
SET BN=""
+34 FOR
SET BN=$ORDER(EPARMS(BN))
IF BN=""
QUIT
SET LIST=LIST_EPARMS(BN)
+35 KILL EPARMS
+36 SET EPARMS=LIST
+37 KILL LIST
End DoDot:1
+38 ;
+39 ; Parse the visit parameters
+40 KILL APCDALVR
+41 FOR BQ=1:1:$LENGTH(VPARMS,$CHAR(28))
Begin DoDot:1
+42 NEW VFIEN
+43 SET VFIEN=$$FIND1^DIC(90506.3,"","MX","PCC Visit","","","ERROR")
+44 SET PDATA=$PIECE(VPARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+45 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+46 IF VALUE=""
QUIT
+47 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
IF PFIEN=""
QUIT
+48 IF "AD"[$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)
SET VALUE=$$DATE^BQIUL1(VALUE)
+49 IF $PIECE(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)="C"
Begin DoDot:2
+50 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+51 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+52 SET APCDALVR(NAME)=VALUE
End DoDot:1
+53 SET APCDALVR("APCDPAT")=DFN
SET APCDPAT=DFN
+54 SET APCDALVR("APCDANE")=""
SET APCDALVR("AUPNTALK")=""
+55 SET APCDALVR("APCDLOC")=$SELECT($GET(APCDALVR("APCDLOC"))'="":APCDALVR("APCDLOC"),1:DUZ(2))
+56 SET APCDALVR("APCDTYPE")=$GET(APCDALVR("APCDTYPE"),"I")
+57 SET APCDALVR("APCDCAT")=$GET(APCDALVR("APCDCAT"),"E")
+58 SET APCDALVR("APCDCLN")=$GET(CLN,"")
+59 IF $GET(MORE)'=""
SET APCDALVR("APCDAUTO")=1
+60 ;
+61 ; Create visit and then update other Vfiles
+62 DO EN^APCDALV
+63 ; Check for error
+64 IF '$GET(APCDALVR("APCDAFLG"))
SET VISIT=$GET(APCDALVR("APCDVSIT"))
+65 IF $GET(APCDALVR("APCDAFLG"))=2
SET RESULT=-1
GOTO DONE
+66 ;
+67 ; If there is an outside provider, set it separately
+68 IF $GET(APCDALVR("APCDTOPR"))'=""
Begin DoDot:1
+69 SET BQIUPD(9000010,VISIT_",",1210)=$GET(APCDALVR("APCDTOPR"))
+70 DO FILE^DIE("","BQIUPD","ERROR")
+71 KILL BQIUPD
End DoDot:1
+72 ;
+73 ; Determine the input template for the event
+74 IF VFILE=9000010.01
SET VFIEN=$ORDER(^BQI(90506.3,"B","Measurement",""))
+75 IF '$TEST
SET VFIEN=$$FIND1^DIC(90506.3,"","M",VFILE,"","","ERROR")
+76 SET VFILE=$$GET1^DIQ(90506.3,VFIEN_",",.02,"E")
+77 SET APCDALVR("APCDATMP")="[APCDALVR "_VFILE_" (ADD)]"
+78 ;
+79 ; Parse the event parameters
+80 FOR BQ=1:1:$LENGTH(EPARMS,$CHAR(28))
Begin DoDot:1
+81 SET PDATA=$PIECE(EPARMS,$CHAR(28),BQ)
IF PDATA=""
QUIT
+82 SET NAME=$PIECE(PDATA,"=",1)
SET VALUE=$PIECE(PDATA,"=",2,99)
+83 IF VALUE=""
QUIT
+84 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",NAME,""))
+85 IF "AD"[$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)
SET VALUE=$$DATE^BQIUL1(VALUE)
+86 IF $PIECE(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)="C"
Begin DoDot:2
+87 SET CHIEN=$ORDER(^BQI(90506.3,VFIEN,10,PFIEN,5,"B",VALUE,""))
IF CHIEN=""
QUIT
+88 SET VALUE=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,5,CHIEN,0),U,2)
End DoDot:2
+89 SET APCDALVR(NAME)=VALUE
+90 SET @NAME=VALUE
+91 IF NAME="VITDTM"
SET APCDALVR("APCDTCDT")=$GET(@NAME)
End DoDot:1
+92 ;
+93 ;Check fields for pointers
+94 SET PRFLD=""
+95 FOR
SET PRFLD=$ORDER(^BQI(90506.3,VFIEN,10,"AC",PRFLD))
IF PRFLD=""
QUIT
Begin DoDot:1
+96 IF $GET(APCDALVR(PRFLD))=""
QUIT
+97 SET PFIEN=$ORDER(^BQI(90506.3,VFIEN,10,"AC",PRFLD,""))
+98 SET PTYP=$PIECE(^BQI(90506.3,VFIEN,10,PFIEN,1),U,1)
+99 IF PTYP'="T"
QUIT
+100 SET PRVAL=APCDALVR(PRFLD)
+101 IF PRFLD="APCDTPRV"
QUIT
+102 SET APCDALVR(PRFLD)="`"_PRVAL
End DoDot:1
+103 ;
+104 ; Check for code set versioning
+105 ;I VFILE=9000010.18 D
+106 ;. I $G(APCDDATE)="" S APCDDATE=$P(^AUPNVSIT(VISIT,0),U,1)\1
+107 ;. I $G(APCDTCPT)'="" D CPT^BQIVFVAL(APCDDATE,APCDTCPT)
+108 ;. I RESULT=1 S APCDALVR("DIFGLINE")=1
+109 ;. I $$PATCH^XPDUTL("BJPC*2.0*1") K APCDALVR("DIFGLINE")
+110 ;
+111 ; Create V files
+112 DO EN^APCDALVR
+113 ; Check for error
+114 IF '$GET(APCDALVR("APCDAFLG"))
SET RESULT=1
+115 IF $GET(APCDALVR("APCDAFLG"))=2
SET RESULT=-1
+116 ;
+117 IF $GET(QUALIF)'=""
IF VFILE=9000010.01
IF RESULT=1
SET IEN=$GET(APCDALVR("APCDADFN"))
DO QLF
+118 ;
+119 ; Cleanup
+120 KILL APCDALVR
+121 ;
DONE ;
+1 SET II=II+1
SET @DATA@(II)=RESULT_$CHAR(30)
+2 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+3 QUIT
+4 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $GET(II)=""
SET II=0
+6 IF $GET(UID)=""
SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+7 IF $GET(DATA)=""
SET DATA=$NAME(^TMP("BQIVFADD",UID))
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
QLF ; Update Qualifiers
+1 IF $GET(^AUPNVMSR(IEN,5,0))=""
SET ^AUPNVMSR(IEN,5,0)="^9000010.015PA^^"
+2 NEW DIC,DA,X,BJ
+3 SET DA(1)=IEN
+4 SET DLAYGO=9000010.015
SET DIC="^AUPNVMSR("_DA(1)_",5,"
SET DIC("P")=DLAYGO
SET DIC(0)="L"
+5 FOR BJ=1:1
SET X=$PIECE(QUALIF,$CHAR(29),BJ)
IF X=""
QUIT
KILL DO,DD
DO FILE^DICN
+6 QUIT
