ACHSPAP1 ; IHS/ITSC/PMF - LINK TO PATIENT CARE COMPONENT (2/2) ; [ 12/06/2002 10:36 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Clarify PCC link messages.
Q
;
CHS ;EP - Create V CHS data
;
S APCDALVR("APCDATMP")="[APCDALVR 9000010.03 (ADD)]"
;
; .01 - Authorizing Facility
S APCDALVR("APCDTFAC")="`"_DUZ(2)
;
; .02 - Patient Name
S APCDALVR("APCDPAT")="`"_$P(ACHSDOCR,U,22)
;
; .04 - Authorization Number
S ACHSX=$P(ACHSDOCR,U,14)
D FYCVT^ACHSFU
S (X,APCDALVR("APCDTAUT"))=$E(ACHSY,3,4)_ACHSFC_$P(ACHSDOCR,U)
X $P(^DD(9000010.03,.04,0),U,5,99)
I '$D(X) S APCDALVR("APCDAFLG")=26_U_APCDALVR("APCDTAUT") Q
;
; .05 - Pay status
S (X,APCDALVR("APCDTPAY"))=$P(ACHSTRAN,U,5)
X $P(^DD(9000010.03,.05,0),U,5,99)
I "FP"'[APCDALVR("APCDTPAY") S APCDALVR("APCDAFLG")=27_U_APCDALVR("APCDTPAY") Q
;
; .06 - Total Charges
I $G(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA")) S X=$P(^("ZA"),U,1)
E S X=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U,1)
S (X,APCDALVR("APCDTTC"))=$FN(X,"",2)
X $P(^DD(9000010.03,.06,0),U,5,99)
I '$D(X) S APCDALVR("APCDAFLG")=28_U_APCDALVR("APCDTTC") Q
;
; .07 - Date of Discharge
S X=$$DOC^ACHS(8,3)
I 'X S X=$P(ACHSTRAN,U,10) I 'X S X=$$DOC^ACHS(3,9) I 'X S X=$$DOC^ACHS(3,1) I 'X S X=$P(ACHSDOCR,U,2)
S APCDALVR("APCDTDD")=X
X $P(^DD(9000010.03,.07,0),U,5,99)
I '$D(X) S APCDALVR("APCDAFLG")=29_U_APCDALVR("APCDTDD") Q
;
; .08 - Discharge Type
; This is a pointer. Must be converted to value.
S APCDALVR("APCDTDT")=1,X=$$DOC^ACHS(8,4)
I X S X=$G(^DIC(42.2,X,9999999)),APCDALVR("APCDTDT")=$S(X=0:5,X=1:1,X=2:5,X=3:2,X=4:3,X=5:3,X=6:4,X=7:4,1:1)
;
; .09 - Newborn DX
; S APCDALVR("APCDTND")=""
;
; .11 - Stillborn
; S APCDALVR("APCDTSB")=""
;
; .12 - No of Visits
S (X,APCDALVR("APCDTNV"))=$P(ACHSTRAN,U,9)
I 'X S APCDALVR("APCDAFLG")=30_U_X Q
X $P(^DD(9000010.03,.12,0),U,5,99)
; GTH 04-23-97 The V CHS dd only goes up to 999, and it's not clear
; if such a high workload is meaningful to PCC. See line below.
I '$D(X) D S:$D(X) APCDALVR("APCDTNV")=X
. F X=9999999,999999,99999,9999,999,99 X $P(^DD(9000010.03,.12,0),U,5,99) Q:$D(X)
.Q
I '$D(X) S APCDALVR("APCDAFLG")=30_U_APCDALVR("APCDTNV") Q
;
;
; .13 - Hospital Voucher No.
; S APCDALVR("APCDTHV")=""
;
; .14 - Vendor
S APCDALVR("APCDTVDR")="`"_$P(ACHSDOCR,U,8)
;
D EN^APCDALVR
;
I $D(APCDALVR("APCDAFLG")) S APCDALVR("APCDAFLG")=APCDALVR("APCDAFLG")_U_"Failed ADD to V CHS." Q
;
I '$$DIE^ACHS("61////"_APCDALVR("APCDADFN")),ACHSWOK W !,"Edit V CHS field of DOCUMENT failed."
Q
;
;
VDEN ;EP Create/update V DENTAL data.
; note : Currently no known way to convert CHS info of CPT,
; TOOTH NUMBER and TOOTH SURFACE to ADA code.
;
F ACHS=0:0 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHS)) Q:'ACHS!$D(APCDALVR("APCDAFLG")) S ACHS("DEN")=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHS,0)) I $P($P(ACHS("DEN"),U),";",2)="AUTTADA(" D VDEN1
K ACHS("DEN")
Q
;
VDEN1 ;
S (DIE,DIC)="^AUTTADA(",DIC(0)=""
S APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"
;
; .01 - ADA Service code - APCDTSC
S (X,APCDALVR("APCDTSC"))="`"_+ACHS("DEN")
X $P(^DD(9000010.05,.01,0),U,5,99)
I '$D(X) S APCDALVR("APCDAFLG")=31_U_APCDALVR("APCDTSC") Q
;
; .02 - Patient Name - APCDPAT
S APCDALVR("APCDPAT")="`"_$P(ACHSDOCR,U,22)
;
; .04 - Number of units - APCDTNOU
S (X,APCDALVR("APCDTNOU"))=$P(ACHS("DEN"),U,4)
X $P(^DD(9000010.05,.04,0),U,5,99)
I '$D(X) S APCDALVR("APCDAFLG")=33_U_APCDALVR("APCDTNOU") Q
;
; .05 - Operative site - APCDTOS
; S APCDALVR("APCDTOS")=""
;
; .06 - Tooth Surface - APCDTSUR
S APCDALVR("APCDTSUR")=$P(ACHS("DEN"),U,9)
X $P(^DD(9000010.05,.06,0),U,5,99)
I '$D(X) S APCDALVR("APCDAFLG")=34_U_APCDALVR("APCDTSUR") Q
;
D EN^APCDALVR
;
I $D(APCDALVR("APCDAFLG")) S APCDALVR("APCDAFLG")=APCDALVR("APCDAFLG")_U_"Add to V DENTAL failed." Q
;
Q
;
VCPT ;EP
;GO THRU 'CPT OR REV INFORMATION' MULTIPLE
;GET THE 'CPT/REV CODE' THEN GLOBAL FROM WHERE THE CODE COMES FROM
;IF = ICPT THEN CONTINUE
F ACHS=0:0 S ACHS=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHS)) Q:'ACHS!$D(APCDALVR("APCDAFLG")) S ACHS("CPT")=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHS,0)) I $P($P(ACHS("CPT"),U),";",2)="ICPT(" D VCPT1
K ACHS("CPT")
Q
VCPT1 ;
S (DIE,DIC)="^ICPT(",DIC(0)=""
S APCDALVR("APCDATMP")="[APCDALVR 9000010.18 (ADD)]"
;
; .01 - CPT Code - APCDTCPT
S (X,APCDALVR("APCDTCPT"))="`"_+ACHS("CPT")
X $P(^DD(9000010.18,.01,0),U,5,99) ;IF NOT AN INACTIVE FLAG THEN
; X CONTAINS THE RESULT OF THE
; LOOKUP
;IF IT CAN'T FIND IT QUIT
I '$D(X) S APCDALVR("APCDAFLG")=32_U_APCDALVR("APCDTCPT") Q
;
; .02 - Patient Name - APCDPAT
S APCDALVR("APCDPAT")="`"_$P(ACHSDOCR,U,22)
;
; .04 - Provider Narrative - APCDTPN
; .05 - Diagnosis - APCDTDX
; .07 - Principal Procedure - APCDTPP
; .16 - Quanty - APCDTUN
; 1201 - Event Date and Time - APCDTCDT
; 1202 - Ordering Provider - APCDTPRV
; 1203 - Clinic - APCDTCLN
; 1204 - Encounter Provider - APCDTEPR
; 1208 - Parent - APCDTPNT
; 1209 - External Key - APCDTEXK
; 1210 - Outside Provider Name - APCDTOPR
;
D EN^APCDALVR
;
I $D(APCDALVR("APCDAFLG")) S APCDALVR("APCDAFLG")=APCDALVR("APCDAFLG")_U_"Add to V CPT failed." Q
;
Q
;
LINK() ;EP - Determine settings in PCC MASTER CONTROL.
N DA,DIC,DR
;I $P($G(^AUTTSITE(1,0)),U,8)'="Y" Q 0;IHS/SET/GTH ACHS*3.1*5 12/06/2002
I $P($G(^AUTTSITE(1,0)),U,8)'="Y" Q "0^PCC is not installed." ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
S DIC="^APCCCTRL("_DUZ(2)_",11,",DIC(0)="",X="CONTRACT HEALTH MGMT SYSTEM"
D ^DIC
K DIC
;Q:Y<1 0;IHS/SET/GTH ACHS*3.1*5 12/06/2002
Q:Y<1 "0^CHS not found in PCC MASTER CONTROL file." ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
S DA=+Y,DA(1)=DUZ(2)
;Q:$$VAL^XBDIQ1(9001000.011,.DA,.02)'="YES" 0;IHS/SET/GTH ACHS*3.1*5 12/06/2002
Q:$$VAL^XBDIQ1(9001000.011,.DA,.02)'="YES" "0^Link not 'YES' to CHS in PCC MASTER CONTROL file." ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
S Y=$$VAL^XBDIQ1(9001000.011,.DA,.03)
I $L(Y) S APCDALVR("APCDTYPE")=$E(Y)
Q 1
;
ACHSPAP1 ; IHS/ITSC/PMF - LINK TO PATIENT CARE COMPONENT (2/2) ; [ 12/06/2002 10:36 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - Clarify PCC link messages.
+3 QUIT
+4 ;
CHS ;EP - Create V CHS data
+1 ;
+2 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.03 (ADD)]"
+3 ;
+4 ; .01 - Authorizing Facility
+5 SET APCDALVR("APCDTFAC")="`"_DUZ(2)
+6 ;
+7 ; .02 - Patient Name
+8 SET APCDALVR("APCDPAT")="`"_$PIECE(ACHSDOCR,U,22)
+9 ;
+10 ; .04 - Authorization Number
+11 SET ACHSX=$PIECE(ACHSDOCR,U,14)
+12 DO FYCVT^ACHSFU
+13 SET (X,APCDALVR("APCDTAUT"))=$EXTRACT(ACHSY,3,4)_ACHSFC_$PIECE(ACHSDOCR,U)
+14 XECUTE $PIECE(^DD(9000010.03,.04,0),U,5,99)
+15 IF '$DATA(X)
SET APCDALVR("APCDAFLG")=26_U_APCDALVR("APCDTAUT")
QUIT
+16 ;
+17 ; .05 - Pay status
+18 SET (X,APCDALVR("APCDTPAY"))=$PIECE(ACHSTRAN,U,5)
+19 XECUTE $PIECE(^DD(9000010.03,.05,0),U,5,99)
+20 IF "FP"'[APCDALVR("APCDTPAY")
SET APCDALVR("APCDAFLG")=27_U_APCDALVR("APCDTPAY")
QUIT
+21 ;
+22 ; .06 - Total Charges
+23 IF $GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"ZA"))
SET X=$PIECE(^("ZA"),U,1)
+24 IF '$TEST
SET X=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")),U,1)
+25 SET (X,APCDALVR("APCDTTC"))=$FNUMBER(X,"",2)
+26 XECUTE $PIECE(^DD(9000010.03,.06,0),U,5,99)
+27 IF '$DATA(X)
SET APCDALVR("APCDAFLG")=28_U_APCDALVR("APCDTTC")
QUIT
+28 ;
+29 ; .07 - Date of Discharge
+30 SET X=$$DOC^ACHS(8,3)
+31 IF 'X
SET X=$PIECE(ACHSTRAN,U,10)
IF 'X
SET X=$$DOC^ACHS(3,9)
IF 'X
SET X=$$DOC^ACHS(3,1)
IF 'X
SET X=$PIECE(ACHSDOCR,U,2)
+32 SET APCDALVR("APCDTDD")=X
+33 XECUTE $PIECE(^DD(9000010.03,.07,0),U,5,99)
+34 IF '$DATA(X)
SET APCDALVR("APCDAFLG")=29_U_APCDALVR("APCDTDD")
QUIT
+35 ;
+36 ; .08 - Discharge Type
+37 ; This is a pointer. Must be converted to value.
+38 SET APCDALVR("APCDTDT")=1
SET X=$$DOC^ACHS(8,4)
+39 IF X
SET X=$GET(^DIC(42.2,X,9999999))
SET APCDALVR("APCDTDT")=$SELECT(X=0:5,X=1:1,X=2:5,X=3:2,X=4:3,X=5:3,X=6:4,X=7:4,1:1)
+40 ;
+41 ; .09 - Newborn DX
+42 ; S APCDALVR("APCDTND")=""
+43 ;
+44 ; .11 - Stillborn
+45 ; S APCDALVR("APCDTSB")=""
+46 ;
+47 ; .12 - No of Visits
+48 SET (X,APCDALVR("APCDTNV"))=$PIECE(ACHSTRAN,U,9)
+49 IF 'X
SET APCDALVR("APCDAFLG")=30_U_X
QUIT
+50 XECUTE $PIECE(^DD(9000010.03,.12,0),U,5,99)
+51 ; GTH 04-23-97 The V CHS dd only goes up to 999, and it's not clear
+52 ; if such a high workload is meaningful to PCC. See line below.
+53 IF '$DATA(X)
Begin DoDot:1
+54 FOR X=9999999,999999,99999,9999,999,99
XECUTE $PIECE(^DD(9000010.03,.12,0),U,5,99)
IF $DATA(X)
QUIT
+55 QUIT
End DoDot:1
IF $DATA(X)
SET APCDALVR("APCDTNV")=X
+56 IF '$DATA(X)
SET APCDALVR("APCDAFLG")=30_U_APCDALVR("APCDTNV")
QUIT
+57 ;
+58 ;
+59 ; .13 - Hospital Voucher No.
+60 ; S APCDALVR("APCDTHV")=""
+61 ;
+62 ; .14 - Vendor
+63 SET APCDALVR("APCDTVDR")="`"_$PIECE(ACHSDOCR,U,8)
+64 ;
+65 DO EN^APCDALVR
+66 ;
+67 IF $DATA(APCDALVR("APCDAFLG"))
SET APCDALVR("APCDAFLG")=APCDALVR("APCDAFLG")_U_"Failed ADD to V CHS."
QUIT
+68 ;
+69 IF '$$DIE^ACHS("61////"_APCDALVR("APCDADFN"))
IF ACHSWOK
WRITE !,"Edit V CHS field of DOCUMENT failed."
+70 QUIT
+71 ;
+72 ;
VDEN ;EP Create/update V DENTAL data.
+1 ; note : Currently no known way to convert CHS info of CPT,
+2 ; TOOTH NUMBER and TOOTH SURFACE to ADA code.
+3 ;
+4 FOR ACHS=0:0
SET ACHS=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHS))
IF 'ACHS!$DATA(APCDALVR("APCDAFLG"))
QUIT
SET ACHS("DEN")=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHS,0))
IF $PIECE($PIECE(ACHS("DEN"),U),";",2)="AUTTADA("
DO VDEN1
+5 KILL ACHS("DEN")
+6 QUIT
+7 ;
VDEN1 ;
+1 SET (DIE,DIC)="^AUTTADA("
SET DIC(0)=""
+2 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.05 (ADD)]"
+3 ;
+4 ; .01 - ADA Service code - APCDTSC
+5 SET (X,APCDALVR("APCDTSC"))="`"_+ACHS("DEN")
+6 XECUTE $PIECE(^DD(9000010.05,.01,0),U,5,99)
+7 IF '$DATA(X)
SET APCDALVR("APCDAFLG")=31_U_APCDALVR("APCDTSC")
QUIT
+8 ;
+9 ; .02 - Patient Name - APCDPAT
+10 SET APCDALVR("APCDPAT")="`"_$PIECE(ACHSDOCR,U,22)
+11 ;
+12 ; .04 - Number of units - APCDTNOU
+13 SET (X,APCDALVR("APCDTNOU"))=$PIECE(ACHS("DEN"),U,4)
+14 XECUTE $PIECE(^DD(9000010.05,.04,0),U,5,99)
+15 IF '$DATA(X)
SET APCDALVR("APCDAFLG")=33_U_APCDALVR("APCDTNOU")
QUIT
+16 ;
+17 ; .05 - Operative site - APCDTOS
+18 ; S APCDALVR("APCDTOS")=""
+19 ;
+20 ; .06 - Tooth Surface - APCDTSUR
+21 SET APCDALVR("APCDTSUR")=$PIECE(ACHS("DEN"),U,9)
+22 XECUTE $PIECE(^DD(9000010.05,.06,0),U,5,99)
+23 IF '$DATA(X)
SET APCDALVR("APCDAFLG")=34_U_APCDALVR("APCDTSUR")
QUIT
+24 ;
+25 DO EN^APCDALVR
+26 ;
+27 IF $DATA(APCDALVR("APCDAFLG"))
SET APCDALVR("APCDAFLG")=APCDALVR("APCDAFLG")_U_"Add to V DENTAL failed."
QUIT
+28 ;
+29 QUIT
+30 ;
VCPT ;EP
+1 ;GO THRU 'CPT OR REV INFORMATION' MULTIPLE
+2 ;GET THE 'CPT/REV CODE' THEN GLOBAL FROM WHERE THE CODE COMES FROM
+3 ;IF = ICPT THEN CONTINUE
+4 FOR ACHS=0:0
SET ACHS=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHS))
IF 'ACHS!$DATA(APCDALVR("APCDAFLG"))
QUIT
SET ACHS("CPT")=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHS,0))
IF $PIECE($PIECE(ACHS("CPT"),U),";",2)="ICPT("
DO VCPT1
+5 KILL ACHS("CPT")
+6 QUIT
VCPT1 ;
+1 SET (DIE,DIC)="^ICPT("
SET DIC(0)=""
+2 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.18 (ADD)]"
+3 ;
+4 ; .01 - CPT Code - APCDTCPT
+5 SET (X,APCDALVR("APCDTCPT"))="`"_+ACHS("CPT")
+6 ;IF NOT AN INACTIVE FLAG THEN
XECUTE $PIECE(^DD(9000010.18,.01,0),U,5,99)
+7 ; X CONTAINS THE RESULT OF THE
+8 ; LOOKUP
+9 ;IF IT CAN'T FIND IT QUIT
+10 IF '$DATA(X)
SET APCDALVR("APCDAFLG")=32_U_APCDALVR("APCDTCPT")
QUIT
+11 ;
+12 ; .02 - Patient Name - APCDPAT
+13 SET APCDALVR("APCDPAT")="`"_$PIECE(ACHSDOCR,U,22)
+14 ;
+15 ; .04 - Provider Narrative - APCDTPN
+16 ; .05 - Diagnosis - APCDTDX
+17 ; .07 - Principal Procedure - APCDTPP
+18 ; .16 - Quanty - APCDTUN
+19 ; 1201 - Event Date and Time - APCDTCDT
+20 ; 1202 - Ordering Provider - APCDTPRV
+21 ; 1203 - Clinic - APCDTCLN
+22 ; 1204 - Encounter Provider - APCDTEPR
+23 ; 1208 - Parent - APCDTPNT
+24 ; 1209 - External Key - APCDTEXK
+25 ; 1210 - Outside Provider Name - APCDTOPR
+26 ;
+27 DO EN^APCDALVR
+28 ;
+29 IF $DATA(APCDALVR("APCDAFLG"))
SET APCDALVR("APCDAFLG")=APCDALVR("APCDAFLG")_U_"Add to V CPT failed."
QUIT
+30 ;
+31 QUIT
+32 ;
LINK() ;EP - Determine settings in PCC MASTER CONTROL.
+1 NEW DA,DIC,DR
+2 ;I $P($G(^AUTTSITE(1,0)),U,8)'="Y" Q 0;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+3 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
IF $PIECE($GET(^AUTTSITE(1,0)),U,8)'="Y"
QUIT "0^PCC is not installed."
+4 SET DIC="^APCCCTRL("_DUZ(2)_",11,"
SET DIC(0)=""
SET X="CONTRACT HEALTH MGMT SYSTEM"
+5 DO ^DIC
+6 KILL DIC
+7 ;Q:Y<1 0;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+8 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
IF Y<1
QUIT "0^CHS not found in PCC MASTER CONTROL file."
+9 SET DA=+Y
SET DA(1)=DUZ(2)
+10 ;Q:$$VAL^XBDIQ1(9001000.011,.DA,.02)'="YES" 0;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+11 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
IF $$VAL^XBDIQ1(9001000.011,.DA,.02)'="YES"
QUIT "0^Link not 'YES' to CHS in PCC MASTER CONTROL file."
+12 SET Y=$$VAL^XBDIQ1(9001000.011,.DA,.03)
+13 IF $LENGTH(Y)
SET APCDALVR("APCDTYPE")=$EXTRACT(Y)
+14 QUIT 1
+15 ;
