Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSA5

ACHSA5.m

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