ACHSA5 ; IHS/ITSC/TPF/PMF - ENTER DOCUMENTS (6/8)-(SCC,DCR,DEST,REF,COM,DAYS) ;JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15,16,21**;JUN 11,2001;Build 43
;ACHS*3.1*14 IHS/OIT/FCJ Fixed the lookup problem when crosswalk was not definned
;ACHS*3.1*15 2.5.2009 IHS/OIT/FCJ FED FACILITIES REQUIRED TO USE VALID SCC
;ACHS*3.1*16 6.10.2009 IHS.OIT.FCJ FX FOR TRIBAL SITE USING NON STANDARD SCC'S
;
B1 ;EP - Input Service Class Code.
W !!,"Service Class Code: "
I $G(ACHSSCC),$D(ACHSSAME),ACHSSAME=$G(ACHSCAN),$D(^ACHS(3,DUZ(2),1,$G(ACHSSCC,"UNDEFINED"),0)) W $P($G(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U),"// "
S ACHSSAME=ACHSCAN
D READ^ACHSFU
I Y="",ACHSSCC S Y=$P($G(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U)
E S ACHSSCC=""
;
I $G(ACHSQUIT) D END^ACHSA Q
;
;GO TO REENTER CAN NUMBER
G A1^ACHSA4:$D(DUOUT),B5:Y'?1"?".E
S (R,ACHSCT)=0
W !!?3,"ITEM #",?12,"SER CL",?20,"DESCRIPTION",!?3,"------",?12,"------",?20,"-----------",!
B2 ;
;LOOP THROUGH 'CHS OBJECT CLASSIFICATION' FILE UNDOCUMENTED X-REF "AC"
S R=$O(^ACHS(3,DUZ(2),"AC",ACHSCC,R)) ;GET 'CODE' IEN
G B4:R=""
S ACHS=$P($G(^ACHS(3,DUZ(2),1,R,0)),U) ;GET ACTUAL 'CODE'
;
;IF CODE IS 252G "NON-FEDERAL HOSPITALIZATION" AND ITS A BLANKET DOC
; 252R "RENAL DIALYSIS (HOSP INP)
; 254B "PHYS INP NON-IHS"
; 254P "RENAL DIALYSIS - PHYS INP"
;SKIP AND CONTINUE LOOP WHY?????
I $D(ACHSBLKF),((ACHS="252G")!(ACHS="252R")!(ACHS="254B")!(ACHS="254P")) G B2
;
;IF 'TYPE OF SERVICE' IS HOSPITAL
;ACHS*3.1*20
;I ACHSTYP=1,+ACHS=252,("FGMR"[$E(ACHS,4)) G B3
I ACHSTYP=1,+ACHS=252,("FGMR"[$E(ACHS,4)),ACHSF638="N" G B3
E I ACHSTYP=1,ACHSF638="Y" G B3
;
;IF 'TYPE OF SERVICE' IS DENTAL AND
;CODE IS 252D "DENTAL LAB SERVICES"
; 254E "DENTIST (DENTAL CARE)
;ACHS*3.1*21 MODIFIED NXT LINE TO TEST FOR 638
;I ACHSTYP=2,((ACHS="252D")!(ACHS="254E")) G B3
I ACHSTYP=2,ACHSF638="N",((ACHS="252D")!(ACHS="254E")) G B3
E I ACHSTYP=2,ACHSF638="Y" G B3
;
; DENTIST (DENTAL CARE)
G B2:ACHSTYP'=3,B2:((+ACHS=252)&("DFGM"[$E(ACHS,4)))!(ACHS="254E")
B3 ;
D OBJCHK
I '$D(ACHSOBOK) G B2
B3A ;
S ACHSCT=ACHSCT+1,ACHS(ACHSCT)=R
W !?5,$J(ACHSCT,3)
W ?12,$P($G(^ACHS(3,DUZ(2),1,R,0),"UNDEFINED"),U) ;'CODE'
W ?20,$P($G(^ACHS(3,DUZ(2),1,R,0),"UNDEFINED"),U,2) ;'DESCRIPTION'
;
I '(ACHSCT#18),'$$DIR^XBDIR("E") G B4
G B2
;
B4 ;
I ACHSCT=0 W *7,!,"No SERVICE CLASS CODES for CAN.",!!,"Notify Site Manager.",! S ACHSSCC="" G A1^ACHSA4 ;GO BACK TO ENTERING CAN NUMBER
W !!?20,"SELECT ITEM (1-",ACHSCT,") "
D READ^ACHSFU
I $G(ACHSQUIT) D END^ACHSA Q
G ACHK^ACHSA4:$D(DUOUT)
G ACHK^ACHSA4:Y="" ;GET CHECK CAN NUMBER
G B4:Y<1!(Y>ACHSCT)
S ACHSSCC=ACHS(Y),Y=$P($G(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U)
W " ",Y
B5 ;
I Y["." S Y=$P(Y,".")_$P(Y,".",2,99)
S:Y]"" ACHSDCR=""
I Y="",ACHSSCC]"" S Y=$P($G(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U) G B6
I Y,'$D(^ACHS(3,DUZ(2),1,"B",Y)) S Y=""
I Y="" W *7," Required" G B1
I +Y=0 G B1
B6 ;
S ACHSOBJC=$$STO(Y)
I $D(ACHSBLKF),((Y="252G")!(Y="252R")!(Y="254B")!(Y="254P")) D NOBLK^ACHSAB G B1
;FCJ ADDED 638 TEST TO NEXT 2 LINES
I ACHSTYP=2,ACHSF638="N" G B8:Y="252D"!(Y="254E") W !!,*7," ONLY 252D or 254E FOR DENTAL." G B1
I ACHSTYP=1,ACHSF638="N" G B8:(+Y=252)&("FGMR"[$E(Y,4)) W !!,*7," ONLY 252G, 252M, 252F OR 252R FOR HOSPITAL CARE" G B1
I ACHSTYP=3,Y="252G"!(Y="252M") W *7,"INVALID INPATIENT SERVICE CLASS." G B1
B8 ;
I ACHSSCC G B9 ;IF WE ALREADY HAVE A SERVICE CLASS CODE SKIP
;
I $L(Y)=4 S X=$O(^ACHS(3,DUZ(2),1,"B",Y,"")) I X,'$P($G(^ACHS(3,DUZ(2),1,X,0)),U,3),'$O(^ACHS(3,DUZ(2),1,"B",Y,X)) S ACHSSCC=X G B9
W *7," ??"
G B1
;
B9 ;
S R=ACHSSCC
D OBJCHK
I '$D(ACHSOBOK) W " ",*7,"INVALID SERVICE CLASS" G B1
K ACHSOBOK,ACHSOBIF
;
D ^ACHSLDCR ;LOCATE DCR FROM CHS SERVICE CLASS DICTIONARY
;
G B1:ACHSDCR=-1
I 'ACHSDCR W *7,!!,"Unspecified DCR For CAN/SERVICE CLASS CODE pair" S ACHSSCC="" G A1^ACHSA4
B10 ;
I +ACHSDCR W !!,"DCR ACCOUNT = ",$P($G(^ACHS(9,DUZ(2),"RN")),U,ACHSDCR)
S ACHSOBJC=$$STO($P($G(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U))
;ACHS*3.1*14 2.27.2008 IHS/OIT/FCJ Fixed the lookup problem when crosswalk was not definned, was setting IEN instead of code
;I ACHSOBJC=-1 W !,"WARNING - NO EQUIVALENT OBJECT CLASS CODE.",!,"USING SERVICE CLASS CODE." S ACHSOBJC=ACHSSCC G B10A
; I ACHSOBJC=-1 W !,"WARNING - NO EQUIVALENT OBJECT CLASS CODE.",!,"USING SERVICE CLASS CODE." S ACHSOBJC=($P($G(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U)) G B10A
;ACHS*3.1*15 2.5.2009 IHS/OIT/FCJ FEDERAL SITES REQUIRED TO USE APPROVED SCC
I ACHSF638="N",ACHSOBJC=-1 W !,"This is an invalid Service class code - NO EQUIVALENT OBJECT CLASS CODE." G B1
I ACHSOBJC=-1 W !,"WARNING - NO EQUIVALENT SERVICE CLASS CODE.",!,"USING OBJECT CLASS CODE." S ACHSOBJC=$P($G(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U)
W !,"OBJECT CLASS CODE = ",$E(ACHSOBJC,1,2),".",$E(ACHSOBJC,3,4)
;ACHS*3.1*16 IHS.OIT.FCJ MODIFIED NXT LINE FOR NON FED OCC'S
I $O(^ACHSOCC("B",ACHSOBJC,0))'="" S ACHSOBJC=$O(^(0)) ; Convert to Pointer.
E S ACHSOBJC=$O(^ACHS(3,DUZ(2),1,"B",ACHSOBJC,0)) G:ACHSOBJC'="" B10A
I ACHSOBJC="" W "INVALID OBJECT CLASS CODE" G B1
W " : ",$P($G(^ACHSOCC(ACHSOBJC,0)),U,2)
B10A ;
S ACHSDEST=$P($G(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U,3)
S:ACHSDEST'="F" ACHSDEST="I"
I $$PARM^ACHS(2,3)'="Y",ACHSDEST="F",$D(ACHSBLKF) G BLKERR
B11 ;
W !
S DIR(0)="9002080.01,13.5"
S:ACHSDEST]"" DIR("B")=ACHSDEST
D ^DIR
K DIR
I $D(DTOUT) D END^ACHSA Q
G ACHK^ACHSA4:$D(DUOUT) ;CHECK CAN NUMBER
S ACHSDEST=Y
D:ACHSDEST="F" SSNCHK
;
B12 ; Check blanket parm., input Dental Referral Type.
I $$PARM^ACHS(2,3)'="Y",ACHSDEST="F",$D(ACHSBLKF) W *7,!,"SITE PARAMETER PREVENTS ISSUE OF BLANKET FOR FI DOCUMENT." G B10
S:'$D(ACHSREFT) ACHSREFT=""
G C1:'((ACHSTYP=2)&(ACHSDEST="F"))
W !
S DIR(0)="9002080.01,83.12",DIR("??")="^D DISPMPC^ACHSA5"
S:ACHSREFT]"" DIR("B")=ACHSREFT
D ^DIR
G B11:$D(DUOUT)!$D(DTOUT),B12:$D(DIRUT)
S ACHSREFT=Y
K DIR
C1 ;EP - Input optional comment.
I $$PARM^ACHS(2,3)'="Y",ACHSDEST="F",$D(ACHSBLKF) G BLKERR
I $D(ACHSSLOC) S ACHSCOPT="SPEC. TRNS" W !!,"Optional comments: ",ACHSCOPT G C2
W !,$$PRMT^ACHSFU(17,ACHSCOPT,10),!,"Optional Comments: "
W:ACHSCOPT]"" ACHSCOPT,"// "
D READ^ACHSFU
I $D(ACHSQUIT) D END^ACHSA Q
G B10:$D(DUOUT)
I Y?1"?".E W !," Enter a Comment (10 chars max) If You Wish",!," Enter An '@' To Delete Current Comment" G C1
G C2:Y=""
I $L(Y)<11 S ACHSCOPT=$S(Y="@":"",1:Y) W:Y="@" " Deleted" G C2
W *7," Too Long"
G C1
;
C2 ;
G E1:ACHSTYP'=1
D1 ; Input estimated LOS.
S:'$D(ACHSESDA) ACHSESDA=""
S DIR(0)="9002080.01,25"
S:ACHSESDA]"" DIR("B")=ACHSESDA
D ^DIR,DIRD^ACHSFU:X="@"
I $D(DTOUT) D END^ACHSA Q
G C1:$D(DUOUT)
S ACHSESDA=Y
K DIR
I Y<15 G E1
W *7
D2 ;
S Y=$$DIR^XBDIR("Y"," Are You Sure "_ACHSESDA_" Days Is Correct","NO","","","",2)
I $D(DIRUT) D END^ACHSA Q
G D1:$D(DUOUT),D1:'Y
E1 ;
G ^ACHSA6 ;ENTER DOCUMENTS (7/8)-(EST. COST, MED DATA)
;
;
BLKERR ; Blanket not allowed.
W !!,*7,"Blankets only valid for IHS Payment Documents",!,"Transaction Cancelled",!!,"'",$P($G(^DD(9002080,14.03,0)),U),"' parameter = '",$$PARM^ACHS(2,3),"'.",!!
D RTRN^ACHS
Q
;
SSNCHK ; Check for SSN.
I $D(DFN),'$P($G(^DPT(DFN,0)),U,9) D
.W *7,!!?17,"*** SSN IS MISSING FOR THIS PATIENT ***",!!?6,"Determination of billing by the Fiscal Intermediary will be greatly",!?11,"aided if you can provide the SSN before printing this PO.",!,*7
.Q
Q
;
OBJCHK ;EP - Check if object class inactivated.
K ACHSOBOK
S ACHSOBIF=$P($G(^ACHS(3,DUZ(2),1,R,0)),U,4)
I ACHSOBIF'="I" S ACHSOBOK="" Q
;
; 'INACTIVATION DATE'
S X=ACHSACFY-1701_"1001",Y=$P($G(^ACHS(3,DUZ(2),1,R,0)),U,5)
I +Y<2900000 W !,*7,?12,$P($G(^ACHS(3,DUZ(2),1,R,0)),U)," INVALID INACTIVATION DATE" Q
Q:X'<7
S ACHSOBOK=""
Q
;
DISPMPC ;EP - From call to DIR, display medical priorities
W !! S %=0
F S %=$O(^DD(9002080.01,83.12,21,%)) Q:'% D Q:$G(ACHSQUIT)
.W !,$G(^DD(9002080.01,83.12,21,%,0))
.I $G(^DD(9002080.01,83.12,21,%+1,0))["REFERRAL" W !,"Press RETURN..." D READ^ACHSFU
Q
;
STO(S) ; Given an SCC, return the OCC.
I '($L(S)=4) Q -1 ; SCC is 4AN.
I ACHSACFY<1998 Q S ; Document must be FY98 or later.
E I ACHSEDOS<$P($$FY^ACHSVAR(98),U) Q S ; Estimated Date of Service must be in FY98 or later.
;Q:'("Q"[$E($P($G(^ACHS(2,ACHSCAN,0)),U),5)) S ; CAN must be FY98 or later.
;Q:'("DQ"[$E($P($G(^ACHS(2,ACHSCAN,0)),U),5)) S ; CAN must be FY98 or later.
I S>2581,S<2586 G 418
N O,T
S O=-1
F %=1:1 S T=$P($T(DATA+%),";",3) Q:T="END" I $P(T,U)=S S O=$P(T,U,2) Q
Q O
;
418 ; Ask user to ID x-walk for Tribal Ops, Contracts, or Indirect
N DIC
S DIC="^ACHSOCC(",DIC(0)="AEMQZ",DIC("S")="I $P(^(0),U)[""418"""
S DIC("S")=DIC("S")_","""_$S(S=2582:"123ABC",S=2584:"4D",S=2585:"5E",1:"")_"""[$E($P(^(0),U),4)"
K S
D ^DIC
I Y>0 Q $P(Y(0),U)
Q -1
;
DATA ;; SCC^OCC
;;2185^2185
;;252A^256Q
;;252B^256Q
;;252H^256Q
;;252J^256Q
;;252D^256R
;;252G^256R
;;252L^256R
;;252M^256R
;;252Q^256R
;;252S^256R
;;254B^256R
;;254D^256R
;;254E^256R
;;254G^256R
;;254J^256R
;;254L^256R
;;254A^256T
;;254C^256T
;;252Z^256Z
;;252F^256W
;;254V^256W
;;2611^2611
;;263A^263A
;;263L^263A
;;263G^263G
;;263K^263K
;;4319^4319
;;8116^8116
;;END
;
ACHSA5 ; IHS/ITSC/TPF/PMF - ENTER DOCUMENTS (6/8)-(SCC,DCR,DEST,REF,COM,DAYS) ;JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15,16,21**;JUN 11,2001;Build 43
+2 ;ACHS*3.1*14 IHS/OIT/FCJ Fixed the lookup problem when crosswalk was not definned
+3 ;ACHS*3.1*15 2.5.2009 IHS/OIT/FCJ FED FACILITIES REQUIRED TO USE VALID SCC
+4 ;ACHS*3.1*16 6.10.2009 IHS.OIT.FCJ FX FOR TRIBAL SITE USING NON STANDARD SCC'S
+5 ;
B1 ;EP - Input Service Class Code.
+1 WRITE !!,"Service Class Code: "
+2 IF $GET(ACHSSCC)
IF $DATA(ACHSSAME)
IF ACHSSAME=$GET(ACHSCAN)
IF $DATA(^ACHS(3,DUZ(2),1,$GET(ACHSSCC,"UNDEFINED"),0))
WRITE $PIECE($GET(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U),"// "
+3 SET ACHSSAME=ACHSCAN
+4 DO READ^ACHSFU
+5 IF Y=""
IF ACHSSCC
SET Y=$PIECE($GET(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U)
+6 IF '$TEST
SET ACHSSCC=""
+7 ;
+8 IF $GET(ACHSQUIT)
DO END^ACHSA
QUIT
+9 ;
+10 ;GO TO REENTER CAN NUMBER
+11 IF $DATA(DUOUT)
GOTO A1^ACHSA4
IF Y'?1"?".E
GOTO B5
+12 SET (R,ACHSCT)=0
+13 WRITE !!?3,"ITEM #",?12,"SER CL",?20,"DESCRIPTION",!?3,"------",?12,"------",?20,"-----------",!
B2 ;
+1 ;LOOP THROUGH 'CHS OBJECT CLASSIFICATION' FILE UNDOCUMENTED X-REF "AC"
+2 ;GET 'CODE' IEN
SET R=$ORDER(^ACHS(3,DUZ(2),"AC",ACHSCC,R))
+3 IF R=""
GOTO B4
+4 ;GET ACTUAL 'CODE'
SET ACHS=$PIECE($GET(^ACHS(3,DUZ(2),1,R,0)),U)
+5 ;
+6 ;IF CODE IS 252G "NON-FEDERAL HOSPITALIZATION" AND ITS A BLANKET DOC
+7 ; 252R "RENAL DIALYSIS (HOSP INP)
+8 ; 254B "PHYS INP NON-IHS"
+9 ; 254P "RENAL DIALYSIS - PHYS INP"
+10 ;SKIP AND CONTINUE LOOP WHY?????
+11 IF $DATA(ACHSBLKF)
IF ((ACHS="252G")!(ACHS="252R")!(ACHS="254B")!(ACHS="254P"))
GOTO B2
+12 ;
+13 ;IF 'TYPE OF SERVICE' IS HOSPITAL
+14 ;ACHS*3.1*20
+15 ;I ACHSTYP=1,+ACHS=252,("FGMR"[$E(ACHS,4)) G B3
+16 IF ACHSTYP=1
IF +ACHS=252
IF ("FGMR"[$EXTRACT(ACHS,4))
IF ACHSF638="N"
GOTO B3
+17 IF '$TEST
IF ACHSTYP=1
IF ACHSF638="Y"
GOTO B3
+18 ;
+19 ;IF 'TYPE OF SERVICE' IS DENTAL AND
+20 ;CODE IS 252D "DENTAL LAB SERVICES"
+21 ; 254E "DENTIST (DENTAL CARE)
+22 ;ACHS*3.1*21 MODIFIED NXT LINE TO TEST FOR 638
+23 ;I ACHSTYP=2,((ACHS="252D")!(ACHS="254E")) G B3
+24 IF ACHSTYP=2
IF ACHSF638="N"
IF ((ACHS="252D")!(ACHS="254E"))
GOTO B3
+25 IF '$TEST
IF ACHSTYP=2
IF ACHSF638="Y"
GOTO B3
+26 ;
+27 ; DENTIST (DENTAL CARE)
+28 IF ACHSTYP'=3
GOTO B2
IF ((+ACHS=252)&("DFGM"[$EXTRACT(ACHS,4)))!(ACHS="254E")
GOTO B2
B3 ;
+1 DO OBJCHK
+2 IF '$DATA(ACHSOBOK)
GOTO B2
B3A ;
+1 SET ACHSCT=ACHSCT+1
SET ACHS(ACHSCT)=R
+2 WRITE !?5,$JUSTIFY(ACHSCT,3)
+3 ;'CODE'
WRITE ?12,$PIECE($GET(^ACHS(3,DUZ(2),1,R,0),"UNDEFINED"),U)
+4 ;'DESCRIPTION'
WRITE ?20,$PIECE($GET(^ACHS(3,DUZ(2),1,R,0),"UNDEFINED"),U,2)
+5 ;
+6 IF '(ACHSCT#18)
IF '$$DIR^XBDIR("E")
GOTO B4
+7 GOTO B2
+8 ;
B4 ;
+1 ;GO BACK TO ENTERING CAN NUMBER
IF ACHSCT=0
WRITE *7,!,"No SERVICE CLASS CODES for CAN.",!!,"Notify Site Manager.",!
SET ACHSSCC=""
GOTO A1^ACHSA4
+2 WRITE !!?20,"SELECT ITEM (1-",ACHSCT,") "
+3 DO READ^ACHSFU
+4 IF $GET(ACHSQUIT)
DO END^ACHSA
QUIT
+5 IF $DATA(DUOUT)
GOTO ACHK^ACHSA4
+6 ;GET CHECK CAN NUMBER
IF Y=""
GOTO ACHK^ACHSA4
+7 IF Y<1!(Y>ACHSCT)
GOTO B4
+8 SET ACHSSCC=ACHS(Y)
SET Y=$PIECE($GET(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U)
+9 WRITE " ",Y
B5 ;
+1 IF Y["."
SET Y=$PIECE(Y,".")_$PIECE(Y,".",2,99)
+2 IF Y]""
SET ACHSDCR=""
+3 IF Y=""
IF ACHSSCC]""
SET Y=$PIECE($GET(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U)
GOTO B6
+4 IF Y
IF '$DATA(^ACHS(3,DUZ(2),1,"B",Y))
SET Y=""
+5 IF Y=""
WRITE *7," Required"
GOTO B1
+6 IF +Y=0
GOTO B1
B6 ;
+1 SET ACHSOBJC=$$STO(Y)
+2 IF $DATA(ACHSBLKF)
IF ((Y="252G")!(Y="252R")!(Y="254B")!(Y="254P"))
DO NOBLK^ACHSAB
GOTO B1
+3 ;FCJ ADDED 638 TEST TO NEXT 2 LINES
+4 IF ACHSTYP=2
IF ACHSF638="N"
IF Y="252D"!(Y="254E")
GOTO B8
WRITE !!,*7," ONLY 252D or 254E FOR DENTAL."
GOTO B1
+5 IF ACHSTYP=1
IF ACHSF638="N"
IF (+Y=252)&("FGMR"[$EXTRACT(Y,4))
GOTO B8
WRITE !!,*7," ONLY 252G, 252M, 252F OR 252R FOR HOSPITAL CARE"
GOTO B1
+6 IF ACHSTYP=3
IF Y="252G"!(Y="252M")
WRITE *7,"INVALID INPATIENT SERVICE CLASS."
GOTO B1
B8 ;
+1 ;IF WE ALREADY HAVE A SERVICE CLASS CODE SKIP
IF ACHSSCC
GOTO B9
+2 ;
+3 IF $LENGTH(Y)=4
SET X=$ORDER(^ACHS(3,DUZ(2),1,"B",Y,""))
IF X
IF '$PIECE($GET(^ACHS(3,DUZ(2),1,X,0)),U,3)
IF '$ORDER(^ACHS(3,DUZ(2),1,"B",Y,X))
SET ACHSSCC=X
GOTO B9
+4 WRITE *7," ??"
+5 GOTO B1
+6 ;
B9 ;
+1 SET R=ACHSSCC
+2 DO OBJCHK
+3 IF '$DATA(ACHSOBOK)
WRITE " ",*7,"INVALID SERVICE CLASS"
GOTO B1
+4 KILL ACHSOBOK,ACHSOBIF
+5 ;
+6 ;LOCATE DCR FROM CHS SERVICE CLASS DICTIONARY
DO ^ACHSLDCR
+7 ;
+8 IF ACHSDCR=-1
GOTO B1
+9 IF 'ACHSDCR
WRITE *7,!!,"Unspecified DCR For CAN/SERVICE CLASS CODE pair"
SET ACHSSCC=""
GOTO A1^ACHSA4
B10 ;
+1 IF +ACHSDCR
WRITE !!,"DCR ACCOUNT = ",$PIECE($GET(^ACHS(9,DUZ(2),"RN")),U,ACHSDCR)
+2 SET ACHSOBJC=$$STO($PIECE($GET(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U))
+3 ;ACHS*3.1*14 2.27.2008 IHS/OIT/FCJ Fixed the lookup problem when crosswalk was not definned, was setting IEN instead of code
+4 ;I ACHSOBJC=-1 W !,"WARNING - NO EQUIVALENT OBJECT CLASS CODE.",!,"USING SERVICE CLASS CODE." S ACHSOBJC=ACHSSCC G B10A
+5 ; I ACHSOBJC=-1 W !,"WARNING - NO EQUIVALENT OBJECT CLASS CODE.",!,"USING SERVICE CLASS CODE." S ACHSOBJC=($P($G(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U)) G B10A
+6 ;ACHS*3.1*15 2.5.2009 IHS/OIT/FCJ FEDERAL SITES REQUIRED TO USE APPROVED SCC
+7 IF ACHSF638="N"
IF ACHSOBJC=-1
WRITE !,"This is an invalid Service class code - NO EQUIVALENT OBJECT CLASS CODE."
GOTO B1
+8 IF ACHSOBJC=-1
WRITE !,"WARNING - NO EQUIVALENT SERVICE CLASS CODE.",!,"USING OBJECT CLASS CODE."
SET ACHSOBJC=$PIECE($GET(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U)
+9 WRITE !,"OBJECT CLASS CODE = ",$EXTRACT(ACHSOBJC,1,2),".",$EXTRACT(ACHSOBJC,3,4)
+10 ;ACHS*3.1*16 IHS.OIT.FCJ MODIFIED NXT LINE FOR NON FED OCC'S
+11 ; Convert to Pointer.
IF $ORDER(^ACHSOCC("B",ACHSOBJC,0))'=""
SET ACHSOBJC=$ORDER(^(0))
+12 IF '$TEST
SET ACHSOBJC=$ORDER(^ACHS(3,DUZ(2),1,"B",ACHSOBJC,0))
IF ACHSOBJC'=""
GOTO B10A
+13 IF ACHSOBJC=""
WRITE "INVALID OBJECT CLASS CODE"
GOTO B1
+14 WRITE " : ",$PIECE($GET(^ACHSOCC(ACHSOBJC,0)),U,2)
B10A ;
+1 SET ACHSDEST=$PIECE($GET(^ACHS(3,DUZ(2),1,ACHSSCC,0)),U,3)
+2 IF ACHSDEST'="F"
SET ACHSDEST="I"
+3 IF $$PARM^ACHS(2,3)'="Y"
IF ACHSDEST="F"
IF $DATA(ACHSBLKF)
GOTO BLKERR
B11 ;
+1 WRITE !
+2 SET DIR(0)="9002080.01,13.5"
+3 IF ACHSDEST]""
SET DIR("B")=ACHSDEST
+4 DO ^DIR
+5 KILL DIR
+6 IF $DATA(DTOUT)
DO END^ACHSA
QUIT
+7 ;CHECK CAN NUMBER
IF $DATA(DUOUT)
GOTO ACHK^ACHSA4
+8 SET ACHSDEST=Y
+9 IF ACHSDEST="F"
DO SSNCHK
+10 ;
B12 ; Check blanket parm., input Dental Referral Type.
+1 IF $$PARM^ACHS(2,3)'="Y"
IF ACHSDEST="F"
IF $DATA(ACHSBLKF)
WRITE *7,!,"SITE PARAMETER PREVENTS ISSUE OF BLANKET FOR FI DOCUMENT."
GOTO B10
+2 IF '$DATA(ACHSREFT)
SET ACHSREFT=""
+3 IF '((ACHSTYP=2)&(ACHSDEST="F"))
GOTO C1
+4 WRITE !
+5 SET DIR(0)="9002080.01,83.12"
SET DIR("??")="^D DISPMPC^ACHSA5"
+6 IF ACHSREFT]""
SET DIR("B")=ACHSREFT
+7 DO ^DIR
+8 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO B11
IF $DATA(DIRUT)
GOTO B12
+9 SET ACHSREFT=Y
+10 KILL DIR
C1 ;EP - Input optional comment.
+1 IF $$PARM^ACHS(2,3)'="Y"
IF ACHSDEST="F"
IF $DATA(ACHSBLKF)
GOTO BLKERR
+2 IF $DATA(ACHSSLOC)
SET ACHSCOPT="SPEC. TRNS"
WRITE !!,"Optional comments: ",ACHSCOPT
GOTO C2
+3 WRITE !,$$PRMT^ACHSFU(17,ACHSCOPT,10),!,"Optional Comments: "
+4 IF ACHSCOPT]""
WRITE ACHSCOPT,"// "
+5 DO READ^ACHSFU
+6 IF $DATA(ACHSQUIT)
DO END^ACHSA
QUIT
+7 IF $DATA(DUOUT)
GOTO B10
+8 IF Y?1"?".E
WRITE !," Enter a Comment (10 chars max) If You Wish",!," Enter An '@' To Delete Current Comment"
GOTO C1
+9 IF Y=""
GOTO C2
+10 IF $LENGTH(Y)<11
SET ACHSCOPT=$SELECT(Y="@":"",1:Y)
IF Y="@"
WRITE " Deleted"
GOTO C2
+11 WRITE *7," Too Long"
+12 GOTO C1
+13 ;
C2 ;
+1 IF ACHSTYP'=1
GOTO E1
D1 ; Input estimated LOS.
+1 IF '$DATA(ACHSESDA)
SET ACHSESDA=""
+2 SET DIR(0)="9002080.01,25"
+3 IF ACHSESDA]""
SET DIR("B")=ACHSESDA
+4 DO ^DIR
IF X="@"
DO DIRD^ACHSFU
+5 IF $DATA(DTOUT)
DO END^ACHSA
QUIT
+6 IF $DATA(DUOUT)
GOTO C1
+7 SET ACHSESDA=Y
+8 KILL DIR
+9 IF Y<15
GOTO E1
+10 WRITE *7
D2 ;
+1 SET Y=$$DIR^XBDIR("Y"," Are You Sure "_ACHSESDA_" Days Is Correct","NO","","","",2)
+2 IF $DATA(DIRUT)
DO END^ACHSA
QUIT
+3 IF $DATA(DUOUT)
GOTO D1
IF 'Y
GOTO D1
E1 ;
+1 ;ENTER DOCUMENTS (7/8)-(EST. COST, MED DATA)
GOTO ^ACHSA6
+2 ;
+3 ;
BLKERR ; Blanket not allowed.
+1 WRITE !!,*7,"Blankets only valid for IHS Payment Documents",!,"Transaction Cancelled",!!,"'",$PIECE($GET(^DD(9002080,14.03,0)),U),"' parameter = '",$$PARM^ACHS(2,3),"'.",!!
+2 DO RTRN^ACHS
+3 QUIT
+4 ;
SSNCHK ; Check for SSN.
+1 IF $DATA(DFN)
IF '$PIECE($GET(^DPT(DFN,0)),U,9)
Begin DoDot:1
+2 WRITE *7,!!?17,"*** SSN IS MISSING FOR THIS PATIENT ***",!!?6,"Determination of billing by the Fiscal Intermediary will be greatly",!?11,"aided if you can provide the SSN before printing this PO.",!,*7
+3 QUIT
End DoDot:1
+4 QUIT
+5 ;
OBJCHK ;EP - Check if object class inactivated.
+1 KILL ACHSOBOK
+2 SET ACHSOBIF=$PIECE($GET(^ACHS(3,DUZ(2),1,R,0)),U,4)
+3 IF ACHSOBIF'="I"
SET ACHSOBOK=""
QUIT
+4 ;
+5 ; 'INACTIVATION DATE'
+6 SET X=ACHSACFY-1701_"1001"
SET Y=$PIECE($GET(^ACHS(3,DUZ(2),1,R,0)),U,5)
+7 IF +Y<2900000
WRITE !,*7,?12,$PIECE($GET(^ACHS(3,DUZ(2),1,R,0)),U)," INVALID INACTIVATION DATE"
QUIT
+8 IF X'<7
QUIT
+9 SET ACHSOBOK=""
+10 QUIT
+11 ;
DISPMPC ;EP - From call to DIR, display medical priorities
+1 WRITE !!
SET %=0
+2 FOR
SET %=$ORDER(^DD(9002080.01,83.12,21,%))
IF '%
QUIT
Begin DoDot:1
+3 WRITE !,$GET(^DD(9002080.01,83.12,21,%,0))
+4 IF $GET(^DD(9002080.01,83.12,21,%+1,0))["REFERRAL"
WRITE !,"Press RETURN..."
DO READ^ACHSFU
End DoDot:1
IF $GET(ACHSQUIT)
QUIT
+5 QUIT
+6 ;
STO(S) ; Given an SCC, return the OCC.
+1 ; SCC is 4AN.
IF '($LENGTH(S)=4)
QUIT -1
+2 ; Document must be FY98 or later.
IF ACHSACFY<1998
QUIT S
+3 ; Estimated Date of Service must be in FY98 or later.
IF '$TEST
IF ACHSEDOS<$PIECE($$FY^ACHSVAR(98),U)
QUIT S
+4 ;Q:'("Q"[$E($P($G(^ACHS(2,ACHSCAN,0)),U),5)) S ; CAN must be FY98 or later.
+5 ;Q:'("DQ"[$E($P($G(^ACHS(2,ACHSCAN,0)),U),5)) S ; CAN must be FY98 or later.
+6 IF S>2581
IF S<2586
GOTO 418
+7 NEW O,T
+8 SET O=-1
+9 FOR %=1:1
SET T=$PIECE($TEXT(DATA+%),";",3)
IF T="END"
QUIT
IF $PIECE(T,U)=S
SET O=$PIECE(T,U,2)
QUIT
+10 QUIT O
+11 ;
418 ; Ask user to ID x-walk for Tribal Ops, Contracts, or Indirect
+1 NEW DIC
+2 SET DIC="^ACHSOCC("
SET DIC(0)="AEMQZ"
SET DIC("S")="I $P(^(0),U)[""418"""
+3 SET DIC("S")=DIC("S")_","""_$SELECT(S=2582:"123ABC",S=2584:"4D",S=2585:"5E",1:"")_"""[$E($P(^(0),U),4)"
+4 KILL S
+5 DO ^DIC
+6 IF Y>0
QUIT $PIECE(Y(0),U)
+7 QUIT -1
+8 ;
DATA ;; SCC^OCC
+1 ;;2185^2185
+2 ;;252A^256Q
+3 ;;252B^256Q
+4 ;;252H^256Q
+5 ;;252J^256Q
+6 ;;252D^256R
+7 ;;252G^256R
+8 ;;252L^256R
+9 ;;252M^256R
+10 ;;252Q^256R
+11 ;;252S^256R
+12 ;;254B^256R
+13 ;;254D^256R
+14 ;;254E^256R
+15 ;;254G^256R
+16 ;;254J^256R
+17 ;;254L^256R
+18 ;;254A^256T
+19 ;;254C^256T
+20 ;;252Z^256Z
+21 ;;252F^256W
+22 ;;254V^256W
+23 ;;2611^2611
+24 ;;263A^263A
+25 ;;263L^263A
+26 ;;263G^263G
+27 ;;263K^263K
+28 ;;4319^4319
+29 ;;8116^8116
+30 ;;END
+31 ;
