BCHABC1 ; IHS/CMI/LAB - CREATE PCC V FILE ENTRIES FROM CHR RECORD 25 Apr 2007 1:50 PM ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
; IHS/TUCSON/DCP - PATCH 4 10/17/97 - change location of a line of
; code in tag POV to avoid UNDEFINED errors.
;
; CMI/TUCSON/LAB - PATCH 5 6/22/98 - change reference to BCHPROB
; to BCHTPROB
; modified V LAB creation
;Create PCC Visit - continued.
;Creates V File entries for V Provider, V POV, V Measurement,
; V Activity Time, V Skin Test, V Lab and Reproductive Factors
;Calls APCDALVR to create entries. If entry fails, a bulletin
; is sent to appropriate users.
;
;IHS/CMI/LAB - 9/17/1998 - - patch 6 changes icd codes to generic for health education and case finding service codes
;
;
VFILES ;EP Create v file entries
D PROV
I $G(BCHQUIT) D VFERROR
D POV
D MEAS
D AT
D PED
D SKINTEST
D LABS
D REPRO
I $D(BCHQUIT) D VFERROR
D KILL
D EOJ
Q
KILL ;
K APCDALVR,BCHPAT,BCHLOC,BCHTYPE,BCHCAT,BCHCLN,BCHTPRO,BCHTPS,BCHTPOV,BCHTNQ,BCHTTOP,BCHTLOU,BCHTPRV,BCHTAT,BCHATMP,BCHAFLG,BCHAUTO,BCHANE,AUPNTALK,BCHAPPT
Q
;
APCDALVR ;call APCDALVR
D ^APCDALVR
I $D(APCDALVR("APCDAFLG")) S BCHQUIT=APCDALVR("APCDAFLG") D VFERROR Q
S BCHV("VFILES",APCDALVR("APCDAVF"),APCDALVR("APCDADFN"))=""
Q
PROV ; v provider
S BCHFILE="V PROVIDER"
D KILL
S APCDALVR("APCDVSIT")=BCHVSIT
S APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4)
S APCDALVR("APCDTPS")="P"
S X=$P(BCHEV("DATA0"),U,3) I $P(^DD(9000010.06,.01,0),U,2)[6 S P=$P(BCHEV("DATA0"),U,3),A=$P(^DIC(3,P,0),U,16) D K A,P Q:X=""
.I A="" S BCHQUIT=42,X="" Q
.I $P(^VA(200,P,0),U)'=$P(^DIC(16,A,0),U) S BCHQUIT=42,X="" Q
.S X=A
I X="" S BCHQUIT=41 Q
I X]"" S APCDALVR("APCDTPRO")="`"_X
D APCDALVR
Q
POV ;create V POVS
S BCHFILE="V POV"
S (BCHX,BCHGOT)=0 F S BCHX=$O(BCHEV("POV",BCHX)) Q:BCHX'=+BCHX D
.S X=$G(BCHEV("POV",BCHX,"SRV")) Q:'$P(X,U,4) ;don't pass non-pcc services
.D KILL
.;IHS/TUCSON/DCP PATCH 4 - next line in wrong place: moved 6 lines down
.;S APCDALVR("APCDTPOV")=BCHEV("POV",BCHX,"ICD9") I APCDALVR("APCDTPOV")="" S BCHQUIT=43 D VFERROR Q
.S APCDALVR("APCDVSIT")=BCHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"
.S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4)
.S APCDALVR("APCDOVRR")=""
.;S APCDALVR("APCDTNQ")="`"_$P(BCHEV("POV",BCHX),U,6)
.;IHS/TUCSON/DCP PATCH 4 - next line moved from old location at POV+5
.S APCDALVR("APCDTPOV")=BCHEV("POV",BCHX,"ICD9") I APCDALVR("APCDTPOV")="" Q ;PATCH 11, don't send bulletin
.I $P($G(BCHEV("POV",BCHX,"SRV")),U,3)="HE" S APCDALVR("APCDTPOV")="V65.49" ;IHS/CMI/LAB - override ICD9 code for Health Education patch 6 09/17/98
.I $P($G(BCHEV("POV",BCHX,"SRV")),U,3)="CF" S APCDALVR("APCDTPOV")="V82.89" ;IHS/CMI/LAB - override ICD9 code for Case Finding/Screening patch 6 09/17/98 ;ICD UPDATE PATCH 11
.S X=$P(BCHEV("POV",BCHX),U,6)
.S X=$S(X:$E($P(^AUTNPOV(X,0),U),1,74),1:$E($P(^BCHTPROB($P(BCHEV("POV",BCHX),U),0),U),1,74)) ;CMI/TUCSON/LAB - changed BCHPROB to BCHTPROB patch 5 6/22/98
.S APCDALVR("APCDTNQ")=X_" - CHR"
.D APCDALVR
.Q
Q
LABS ;
Q:'$D(BCHEV("DATA13")) ;no labs passed
Q:$G(BCHEV("DATA13"))="" ;no labs passed
S BCHFILE="V LAB"
S %=$P($G(^BCHSITE(DUZ(2),0)),U,12) I % S %="`"_%
I %="" S %="BLOOD SUGAR"
S BCHMEAS=%_";;THROAT CULTURE;;UA;;HCT" ;IHS/TUCSON/LAB - reversed UA and HCT patch 5
F BCHX=1:2:7 I $P(BCHEV("DATA13"),U,BCHX)!($P(BCHEV("DATA13"),U,(BCHX+1))]"") D ;IHS/TUCSON/LAB - modified 8 to 7 patch 5
.D KILL
.S APCDALVR("APCDVSIT")=BCHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.09 (ADD)]"
.S APCDALVR("APCDTLAB")=$P(BCHMEAS,";",BCHX)
.S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4)
.S APCDALVR("APCDTRES")=$P(BCHEV("DATA13"),U,(BCHX+1))
.D APCDALVR
.Q
S Z=$P($G(^BCHSITE(DUZ(2),0)),U,17) I Z S Z="`"_Z
I Z="" S Z="HEMOGLOBIN A1C"
I $P(BCHEV("DATA13"),U,9)]"" D
.D KILL
.S APCDALVR("APCDVSIT")=BCHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.09 (ADD)]"
.S APCDALVR("APCDTLAB")=Z
.S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4)
.S APCDALVR("APCDTRES")=$P(BCHEV("DATA13"),U,9)
.D APCDALVR
.Q
K BCHMEAS,BCHX
Q
REPRO ;reproductive factors
Q:$P(^DPT($P(BCHEV("DATA0"),U,4),0),U,2)'="F"
I $P($G(BCHEV("DATA0")),U,13)="",$P($G(BCHEV("DATA0")),U,14)="" Q
K BCHQUIT
S BCHFILE="REPRODUCTIVE FACTORS"
I '$D(^AUPNREP($P(BCHEV("DATA0"),U,4))) S X=$P(BCHEV("DATA0"),U,4),DLAYGO=9000017,DIADD=1,DINUM=X,DIC="^AUPNREP(",DIC(0)="L" K DD D FILE^DICN K DIC,DA,DIADD,DLAYGO,X D Q:$D(BCHQUIT)
.I Y=-1 S BCHQUIT=44 Q
.Q
K DR,DIE
I $P(BCHEV("DATA0"),U,13)]"" S Y=$P(BCHEV("DATA0"),U,13) D DD^%DT S DR="2///"_Y_";2.1///^S X="_$P(BCHEV("DATA0"),U),DA=$P(BCHEV("DATA0"),U,4),DIE="^AUPNREP(" D ^DIE K DIE,DA,DR,DIV,DIY,DIW I $D(Y) S BCHQUIT=45 Q
I $P(BCHEV("DATA0"),U,14)]"" S Y=$P(BCHEV("DATA0"),U,14) S Y=$P(^BCHTFPM(Y,0),U,3) S DR="3///"_Y_";3.1///^S X="_$P($P(BCHEV("DATA0"),U),"."),DA=$P(BCHEV("DATA0"),U,4),DIE="^AUPNREP(" D ^DIE K DIE,DA,DR,DIV,DIY,DIW I $D(Y) S BCHQUIT=45 Q
Q
MEAS ;
Q:'$D(BCHEV("DATA12")) ;no measurements passed
Q:$G(BCHEV("DATA12"))="" ;no measurements passed
S BCHFILE="V MEASUREMENT"
S BCHMEAS="BP;WT;HT;HC;VU;VC;TMP;PU;RS;"
F BCHX=1:1:9 I $P(BCHEV("DATA12"),U,BCHX)]"" D
.D KILL
.S APCDALVR("APCDVSIT")=BCHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
.S APCDALVR("APCDTTYP")=$P(BCHMEAS,";",BCHX)
.S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4)
.S APCDALVR("APCDTVAL")=$P(BCHEV("DATA12"),"^",BCHX)
.D APCDALVR
.Q
K BCHMEAS,BCHX
Q
SKINTEST ;
Q:$P($G(BCHEV("DATA12")),U,10)=""
S BCHFILE="V SKIN TEST"
D KILL
S APCDALVR("APCDTSK")="PPD"
S APCDALVR("APCDVSIT")=BCHVSIT
S APCDALVR("APCDATMP")="[APCDALVR 9000010.12 (ADD)]"
S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4)
S APCDALVR("APCDTREA")=$P(BCHEV("DATA12"),U,10)
S Y=$P($P(BCHEV("DATA0"),U),".") D DD^%DT S APCDALVR("APCDTDR")=Y
D APCDALVR
Q
AT ;create v activity time record
S BCHFILE="V ACTIVITY TIME"
D KILL
S (BCHX,BCHT)=0 F S BCHX=$O(BCHEV("POV",BCHX)) Q:BCHX'=+BCHX S BCHT=BCHT+$P(BCHEV("POV",BCHX),U,5)
S APCDALVR("APCDTACT")=BCHT
S APCDALVR("APCDVSIT")=BCHVSIT
S APCDALVR("APCDATMP")="[APCDALVR 9000010.19 (ADD)]"
S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4)
S APCDALVR("APCDTTM")=+$P(BCHEV("DATA0"),U,11)
D APCDALVR
Q
PED ;
S BCHFILE="PAT ED"
S (BCHX,BCHGOT)=0 F S BCHX=$O(BCHEV("EDUC",BCHX)) Q:BCHX'=+BCHX D
.D KILL
.S APCDALVR("APCDVSIT")=BCHVSIT
.S APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
.S APCDALVR("APCDPAT")=$P(BCHEV("DATA0"),U,4)
.S APCDALVR("APCDTTOP")="`"_$P(BCHEV("EDUC",BCHX),U)
.S X=$P(BCHEV("EDUC",BCHX),U,5) I X D I X S APCDALVR("APCDTPRO")="`"_X
..I $P(^DD(9000010.16,.05,0),U,2)[6 S X=$G(^DIC(16,X,"A3"))
..Q
.S APCDALVR("APCDTIG")=$P(BCHEV("EDUC",BCHX),U,7)
.S APCDALVR("APCDTMIN")=$P(BCHEV("EDUC",BCHX),U,8)
.S APCDALVR("APCDTLOU")=$P(BCHEV("EDUC",BCHX),U,6)
.S APCDALVR("APCDTOBJ")=$TR($P(BCHEV("EDUC",BCHX),U,14),";",",")
.S APCDALVR("APCDOVRR")=""
.D APCDALVR
.Q
Q
EOJ ;
D KILL
K BCHDATK,BCHPAT,BCHX,BCHACTL,BCHLOC
Q
VFERROR ;EP
S BCHIEN=BCHEV("CHR IEN")
S BCHERR="VE"_BCHQUIT,BCHERR=$P($T(@BCHERR),";;",2)
D LBULL^BCHALD
K BCHQUIT,BCHERR
Q
;
VE1 ;;incorrect template specification
VE2 ;;invalid values being passed to V file.
VE3 ;;invalid visit parameters (date, location etc.)
VE41 ;;No PROVIDER ENTRY PASSED from CHR SYSTEM.
VE42 ;;Could NOT convert 200 Pointer to 6 pointer.
VE43 ;;Could not find ICD9 code in ICD DIagnosis file.
VE44 ;;Could not create entry in Reproductive Factors file
VE45 ;;Error updating LMP or FP Method in Reproductive Factors file
BCHABC1 ; IHS/CMI/LAB - CREATE PCC V FILE ENTRIES FROM CHR RECORD 25 Apr 2007 1:50 PM ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
+3 ; IHS/TUCSON/DCP - PATCH 4 10/17/97 - change location of a line of
+4 ; code in tag POV to avoid UNDEFINED errors.
+5 ;
+6 ; CMI/TUCSON/LAB - PATCH 5 6/22/98 - change reference to BCHPROB
+7 ; to BCHTPROB
+8 ; modified V LAB creation
+9 ;Create PCC Visit - continued.
+10 ;Creates V File entries for V Provider, V POV, V Measurement,
+11 ; V Activity Time, V Skin Test, V Lab and Reproductive Factors
+12 ;Calls APCDALVR to create entries. If entry fails, a bulletin
+13 ; is sent to appropriate users.
+14 ;
+15 ;IHS/CMI/LAB - 9/17/1998 - - patch 6 changes icd codes to generic for health education and case finding service codes
+16 ;
+17 ;
VFILES ;EP Create v file entries
+1 DO PROV
+2 IF $GET(BCHQUIT)
DO VFERROR
+3 DO POV
+4 DO MEAS
+5 DO AT
+6 DO PED
+7 DO SKINTEST
+8 DO LABS
+9 DO REPRO
+10 IF $DATA(BCHQUIT)
DO VFERROR
+11 DO KILL
+12 DO EOJ
+13 QUIT
KILL ;
+1 KILL APCDALVR,BCHPAT,BCHLOC,BCHTYPE,BCHCAT,BCHCLN,BCHTPRO,BCHTPS,BCHTPOV,BCHTNQ,BCHTTOP,BCHTLOU,BCHTPRV,BCHTAT,BCHATMP,BCHAFLG,BCHAUTO,BCHANE,AUPNTALK,BCHAPPT
+2 QUIT
+3 ;
APCDALVR ;call APCDALVR
+1 DO ^APCDALVR
+2 IF $DATA(APCDALVR("APCDAFLG"))
SET BCHQUIT=APCDALVR("APCDAFLG")
DO VFERROR
QUIT
+3 SET BCHV("VFILES",APCDALVR("APCDAVF"),APCDALVR("APCDADFN"))=""
+4 QUIT
PROV ; v provider
+1 SET BCHFILE="V PROVIDER"
+2 DO KILL
+3 SET APCDALVR("APCDVSIT")=BCHVSIT
+4 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.06 (ADD)]"
+5 SET APCDALVR("APCDPAT")=$PIECE(BCHEV("DATA0"),U,4)
+6 SET APCDALVR("APCDTPS")="P"
+7 SET X=$PIECE(BCHEV("DATA0"),U,3)
IF $PIECE(^DD(9000010.06,.01,0),U,2)[6
SET P=$PIECE(BCHEV("DATA0"),U,3)
SET A=$PIECE(^DIC(3,P,0),U,16)
Begin DoDot:1
+8 IF A=""
SET BCHQUIT=42
SET X=""
QUIT
+9 IF $PIECE(^VA(200,P,0),U)'=$PIECE(^DIC(16,A,0),U)
SET BCHQUIT=42
SET X=""
QUIT
+10 SET X=A
End DoDot:1
KILL A,P
IF X=""
QUIT
+11 IF X=""
SET BCHQUIT=41
QUIT
+12 IF X]""
SET APCDALVR("APCDTPRO")="`"_X
+13 DO APCDALVR
+14 QUIT
POV ;create V POVS
+1 SET BCHFILE="V POV"
+2 SET (BCHX,BCHGOT)=0
FOR
SET BCHX=$ORDER(BCHEV("POV",BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+3 ;don't pass non-pcc services
SET X=$GET(BCHEV("POV",BCHX,"SRV"))
IF '$PIECE(X,U,4)
QUIT
+4 DO KILL
+5 ;IHS/TUCSON/DCP PATCH 4 - next line in wrong place: moved 6 lines down
+6 ;S APCDALVR("APCDTPOV")=BCHEV("POV",BCHX,"ICD9") I APCDALVR("APCDTPOV")="" S BCHQUIT=43 D VFERROR Q
+7 SET APCDALVR("APCDVSIT")=BCHVSIT
+8 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"
+9 SET APCDALVR("APCDPAT")=$PIECE(BCHEV("DATA0"),U,4)
+10 SET APCDALVR("APCDOVRR")=""
+11 ;S APCDALVR("APCDTNQ")="`"_$P(BCHEV("POV",BCHX),U,6)
+12 ;IHS/TUCSON/DCP PATCH 4 - next line moved from old location at POV+5
+13 ;PATCH 11, don't send bulletin
SET APCDALVR("APCDTPOV")=BCHEV("POV",BCHX,"ICD9")
IF APCDALVR("APCDTPOV")=""
QUIT
+14 ;IHS/CMI/LAB - override ICD9 code for Health Education patch 6 09/17/98
IF $PIECE($GET(BCHEV("POV",BCHX,"SRV")),U,3)="HE"
SET APCDALVR("APCDTPOV")="V65.49"
+15 ;IHS/CMI/LAB - override ICD9 code for Case Finding/Screening patch 6 09/17/98 ;ICD UPDATE PATCH 11
IF $PIECE($GET(BCHEV("POV",BCHX,"SRV")),U,3)="CF"
SET APCDALVR("APCDTPOV")="V82.89"
+16 SET X=$PIECE(BCHEV("POV",BCHX),U,6)
+17 ;CMI/TUCSON/LAB - changed BCHPROB to BCHTPROB patch 5 6/22/98
SET X=$SELECT(X:$EXTRACT($PIECE(^AUTNPOV(X,0),U),1,74),1:$EXTRACT($PIECE(^BCHTPROB($PIECE(BCHEV("POV",BCHX),U),0),U),1,74))
+18 SET APCDALVR("APCDTNQ")=X_" - CHR"
+19 DO APCDALVR
+20 QUIT
End DoDot:1
+21 QUIT
LABS ;
+1 ;no labs passed
IF '$DATA(BCHEV("DATA13"))
QUIT
+2 ;no labs passed
IF $GET(BCHEV("DATA13"))=""
QUIT
+3 SET BCHFILE="V LAB"
+4 SET %=$PIECE($GET(^BCHSITE(DUZ(2),0)),U,12)
IF %
SET %="`"_%
+5 IF %=""
SET %="BLOOD SUGAR"
+6 ;IHS/TUCSON/LAB - reversed UA and HCT patch 5
SET BCHMEAS=%_";;THROAT CULTURE;;UA;;HCT"
+7 ;IHS/TUCSON/LAB - modified 8 to 7 patch 5
FOR BCHX=1:2:7
IF $PIECE(BCHEV("DATA13"),U,BCHX)!($PIECE(BCHEV("DATA13"),U,(BCHX+1))]"")
Begin DoDot:1
+8 DO KILL
+9 SET APCDALVR("APCDVSIT")=BCHVSIT
+10 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.09 (ADD)]"
+11 SET APCDALVR("APCDTLAB")=$PIECE(BCHMEAS,";",BCHX)
+12 SET APCDALVR("APCDPAT")=$PIECE(BCHEV("DATA0"),U,4)
+13 SET APCDALVR("APCDTRES")=$PIECE(BCHEV("DATA13"),U,(BCHX+1))
+14 DO APCDALVR
+15 QUIT
End DoDot:1
+16 SET Z=$PIECE($GET(^BCHSITE(DUZ(2),0)),U,17)
IF Z
SET Z="`"_Z
+17 IF Z=""
SET Z="HEMOGLOBIN A1C"
+18 IF $PIECE(BCHEV("DATA13"),U,9)]""
Begin DoDot:1
+19 DO KILL
+20 SET APCDALVR("APCDVSIT")=BCHVSIT
+21 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.09 (ADD)]"
+22 SET APCDALVR("APCDTLAB")=Z
+23 SET APCDALVR("APCDPAT")=$PIECE(BCHEV("DATA0"),U,4)
+24 SET APCDALVR("APCDTRES")=$PIECE(BCHEV("DATA13"),U,9)
+25 DO APCDALVR
+26 QUIT
End DoDot:1
+27 KILL BCHMEAS,BCHX
+28 QUIT
REPRO ;reproductive factors
+1 IF $PIECE(^DPT($PIECE(BCHEV("DATA0"),U,4),0),U,2)'="F"
QUIT
+2 IF $PIECE($GET(BCHEV("DATA0")),U,13)=""
IF $PIECE($GET(BCHEV("DATA0")),U,14)=""
QUIT
+3 KILL BCHQUIT
+4 SET BCHFILE="REPRODUCTIVE FACTORS"
+5 IF '$DATA(^AUPNREP($PIECE(BCHEV("DATA0"),U,4)))
SET X=$PIECE(BCHEV("DATA0"),U,4)
SET DLAYGO=9000017
SET DIADD=1
SET DINUM=X
SET DIC="^AUPNREP("
SET DIC(0)="L"
KILL DD
DO FILE^DICN
KILL DIC,DA,DIADD,DLAYGO,X
Begin DoDot:1
+6 IF Y=-1
SET BCHQUIT=44
QUIT
+7 QUIT
End DoDot:1
IF $DATA(BCHQUIT)
QUIT
+8 KILL DR,DIE
+9 IF $PIECE(BCHEV("DATA0"),U,13)]""
SET Y=$PIECE(BCHEV("DATA0"),U,13)
DO DD^%DT
SET DR="2///"_Y_";2.1///^S X="_$PIECE(BCHEV("DATA0"),U)
SET DA=$PIECE(BCHEV("DATA0"),U,4)
SET DIE="^AUPNREP("
DO ^DIE
KILL DIE,DA,DR,DIV,DIY,DIW
IF $DATA(Y)
SET BCHQUIT=45
QUIT
+10 IF $PIECE(BCHEV("DATA0"),U,14)]""
SET Y=$PIECE(BCHEV("DATA0"),U,14)
SET Y=$PIECE(^BCHTFPM(Y,0),U,3)
SET DR="3///"_Y_";3.1///^S X="_$PIECE($PIECE(BCHEV("DATA0"),U),".")
SET DA=$PIECE(BCHEV("DATA0"),U,4)
SET DIE="^AUPNREP("
DO ^DIE
KILL DIE,DA,DR,DIV,DIY,DIW
IF $DATA(Y)
SET BCHQUIT=45
QUIT
+11 QUIT
MEAS ;
+1 ;no measurements passed
IF '$DATA(BCHEV("DATA12"))
QUIT
+2 ;no measurements passed
IF $GET(BCHEV("DATA12"))=""
QUIT
+3 SET BCHFILE="V MEASUREMENT"
+4 SET BCHMEAS="BP;WT;HT;HC;VU;VC;TMP;PU;RS;"
+5 FOR BCHX=1:1:9
IF $PIECE(BCHEV("DATA12"),U,BCHX)]""
Begin DoDot:1
+6 DO KILL
+7 SET APCDALVR("APCDVSIT")=BCHVSIT
+8 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.01 (ADD)]"
+9 SET APCDALVR("APCDTTYP")=$PIECE(BCHMEAS,";",BCHX)
+10 SET APCDALVR("APCDPAT")=$PIECE(BCHEV("DATA0"),U,4)
+11 SET APCDALVR("APCDTVAL")=$PIECE(BCHEV("DATA12"),"^",BCHX)
+12 DO APCDALVR
+13 QUIT
End DoDot:1
+14 KILL BCHMEAS,BCHX
+15 QUIT
SKINTEST ;
+1 IF $PIECE($GET(BCHEV("DATA12")),U,10)=""
QUIT
+2 SET BCHFILE="V SKIN TEST"
+3 DO KILL
+4 SET APCDALVR("APCDTSK")="PPD"
+5 SET APCDALVR("APCDVSIT")=BCHVSIT
+6 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.12 (ADD)]"
+7 SET APCDALVR("APCDPAT")=$PIECE(BCHEV("DATA0"),U,4)
+8 SET APCDALVR("APCDTREA")=$PIECE(BCHEV("DATA12"),U,10)
+9 SET Y=$PIECE($PIECE(BCHEV("DATA0"),U),".")
DO DD^%DT
SET APCDALVR("APCDTDR")=Y
+10 DO APCDALVR
+11 QUIT
AT ;create v activity time record
+1 SET BCHFILE="V ACTIVITY TIME"
+2 DO KILL
+3 SET (BCHX,BCHT)=0
FOR
SET BCHX=$ORDER(BCHEV("POV",BCHX))
IF BCHX'=+BCHX
QUIT
SET BCHT=BCHT+$PIECE(BCHEV("POV",BCHX),U,5)
+4 SET APCDALVR("APCDTACT")=BCHT
+5 SET APCDALVR("APCDVSIT")=BCHVSIT
+6 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.19 (ADD)]"
+7 SET APCDALVR("APCDPAT")=$PIECE(BCHEV("DATA0"),U,4)
+8 SET APCDALVR("APCDTTM")=+$PIECE(BCHEV("DATA0"),U,11)
+9 DO APCDALVR
+10 QUIT
PED ;
+1 SET BCHFILE="PAT ED"
+2 SET (BCHX,BCHGOT)=0
FOR
SET BCHX=$ORDER(BCHEV("EDUC",BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+3 DO KILL
+4 SET APCDALVR("APCDVSIT")=BCHVSIT
+5 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.16 (ADD)]"
+6 SET APCDALVR("APCDPAT")=$PIECE(BCHEV("DATA0"),U,4)
+7 SET APCDALVR("APCDTTOP")="`"_$PIECE(BCHEV("EDUC",BCHX),U)
+8 SET X=$PIECE(BCHEV("EDUC",BCHX),U,5)
IF X
Begin DoDot:2
+9 IF $PIECE(^DD(9000010.16,.05,0),U,2)[6
SET X=$GET(^DIC(16,X,"A3"))
+10 QUIT
End DoDot:2
IF X
SET APCDALVR("APCDTPRO")="`"_X
+11 SET APCDALVR("APCDTIG")=$PIECE(BCHEV("EDUC",BCHX),U,7)
+12 SET APCDALVR("APCDTMIN")=$PIECE(BCHEV("EDUC",BCHX),U,8)
+13 SET APCDALVR("APCDTLOU")=$PIECE(BCHEV("EDUC",BCHX),U,6)
+14 SET APCDALVR("APCDTOBJ")=$TRANSLATE($PIECE(BCHEV("EDUC",BCHX),U,14),";",",")
+15 SET APCDALVR("APCDOVRR")=""
+16 DO APCDALVR
+17 QUIT
End DoDot:1
+18 QUIT
EOJ ;
+1 DO KILL
+2 KILL BCHDATK,BCHPAT,BCHX,BCHACTL,BCHLOC
+3 QUIT
VFERROR ;EP
+1 SET BCHIEN=BCHEV("CHR IEN")
+2 SET BCHERR="VE"_BCHQUIT
SET BCHERR=$PIECE($TEXT(@BCHERR),";;",2)
+3 DO LBULL^BCHALD
+4 KILL BCHQUIT,BCHERR
+5 QUIT
+6 ;
VE1 ;;incorrect template specification
VE2 ;;invalid values being passed to V file.
VE3 ;;invalid visit parameters (date, location etc.)
VE41 ;;No PROVIDER ENTRY PASSED from CHR SYSTEM.
VE42 ;;Could NOT convert 200 Pointer to 6 pointer.
VE43 ;;Could not find ICD9 code in ICD DIagnosis file.
VE44 ;;Could not create entry in Reproductive Factors file
VE45 ;;Error updating LMP or FP Method in Reproductive Factors file
