ACHSDF ; IHS/ITSC/PMF - UNMET NEEDS DATA ENTRY (1/2) ; [ 03/24/2005 8:22 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUN 11, 2001;Build 43
;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
;
D SETCK^ACHSDF1 ;SET UP SITE PARAMETERS
Q:$G(ACHDXQT)
START ; --- Set Temporary Number.
I $D(^ACHSDEF(DUZ(2),"D",0))=0 S ^ACHSDEF(DUZ(2),"D",0)="^9002066.01A^0^0"
S DIC="^ACHSDEF("_DUZ(2)_",""D"","
S DA(1)=DUZ(2)
S DIC(0)="L"
S X="#"_$P($H,",",1)_"#"_$P($H,",",2)
D ^DIC
I +Y<1 S ACHDXIT="" D END Q
S ACHSA=+Y
;
;FORCE ENTER 'DATE OF SERVICE' AND 'ISSUED BY'
I '$$DIE("2////"_DT_";3////"_DUZ,2) S ACHDXIT="" D END Q
D PAT
Q:X[U
D END
Q
;
PAT ; --- Is Patient Registered.
K DQ
Q:'$$DIE("5//Y",2)
I $D(Y) S ACHDXIT="" Q
I $$DF^ACHS(0,5)="N" G PATNOT
;
;ITSC/SET/JVK ACHS*3.1*12 ADD CHANGES FOR IHS/OKCAO/POC PAWNEE BEN PKG
;Q:'$$DIE(6,2)
;I +$P($G(^AUTTLOC(DUZ(2),0)),U,10)=505613 Q:'$$DIEPWN ;ACHS*3.1*18 3.12.2010 IHS.OIT.FCJ ADDED ACHSDXIT TST
I +$P($G(^AUTTLOC(DUZ(2),0)),U,10)=505613 Q:('$$DIEPWN)!(ACHDXIT) Q
E Q:'$$DIE(6,2)
;ITSC/SET/JVK END CHANGES ACHS*3.1*12
I $D(Y) S ACHDXIT="" Q
I '$$DF^ACHS(0,6) W !,*7,"A Patient Name Must Be Entered",!! G PAT
D USER
Q
;
PATNOT ; --- Patient not on file.
K DQ
Q:'$$DIE("7:13")
I $D(Y) G PAT
I '$L($$DF^ACHS(0,7)) W !,*7,"A Patient Name Must Be Entered",!! G PAT
D USER
Q
;
USER ; --- Set variables to file.
Q:'$$DIE("3////"_DUZ)
I $D(Y) S ACHDXIT="" Q
D ISSDT
Q
;
ISSDT ; --- Issue Date.
Q:'$$DIE("2////"_DT)
I $D(Y) S ACHDXIT="" Q
D REQ
Q
;
REQ ; --- Date Request Received.
Q:'$$DIE(4,2)
I $D(Y) S ACHDXIT="" Q
I '$$DF^ACHS(0,4) W !,*7,"A Date Received Request Must Be Entered" G REQ
D DEFCAT
Q
;
DEFCAT ; --- Deferred Service Category.
W !!
;{ABK,7/9/10}S DIC="^ACHSDFC(",DIC(0)="QAEM",DIC("A")="Enter Deferred Service Category: "
S DIC="^ACHSDFC(",DIC(0)="QAEM",DIC("A")="Enter Unmet Need Category: "
D ^DIC
I X=U Q
;{ABK,7/9/10}I Y<0 W *7,!!,"Must Have Deferred Services Category",! G DEFCAT
I Y<0 W *7,!!,"Must Have Unmet Need Category",! G DEFCAT
S ACHDCAT=+Y
Q:'$$DIE("100////"_ACHDCAT)
;
DEFSUB ; --- Deferred Service Subcategory
W !!
;{ABK,7/9/10}S DIC="^ACHSDFC("_ACHDCAT_",1,",DIC(0)="AQEM",DIC("A")="Enter Deferred Service Subcategory: "
S DIC="^ACHSDFC("_ACHDCAT_",1,",DIC(0)="AQEM",DIC("A")="Enter Unmet Need Subcategory: "
D ^DIC
I X=U Q
;{ABK,7/9/10}I Y<0 W *7,!!,"Must Have Deferred Service Subcategory",! G DEFSUB
I Y<0 W *7,!!,"Must Have Unmet Need Subcategory",! G DEFSUB
S ACHDSUB=+Y
Q:'$$DIE("105////"_ACHDSUB)
Q:'$$DIE("110:130",2)
I $D(Y) G DEFCAT
D DEFDIAG
Q
;
DEFDIAG ; --- Deferred Service Diagnosis.
I $$DF^ACHS(100,2)="O" G DEFPROC
Q:'$$DIE(200,2)
I $D(Y) S ACHDXIT="" Q
;ACHS*3.1*23 CHG ICD9 TO ICD IN NXT LINE
I '$D(^ACHSDEF(DUZ(2),"D",ACHSA,200,0)) W !,*7,"An ICD Diagnosis Code Must Be Entered",!! G DEFDIAG
D DEFCMT
Q
;
DEFPROC ; --- Deferred Service CPT.
Q:'$$DIE(300,2)
I $D(Y) S ACHDXIT="" Q
I '$D(^ACHSDEF(DUZ(2),"D",ACHSA,300,0)) W !,*7,"A CPT Procedure Code Must Be Entered",!! G DEFPROC
D DEFCMT
Q
;
DEFCMT ; --- Comment.
Q:'$$DIE(400,2)
I $D(Y) S ACHDXIT="" Q
D DEFDCT
Q
;
DEFDCT ; --- Document Control.
W !!
K DIR
S DIR(0)="Y",DIR("A")="Enter Document Control Information Now",DIR("B")="NO"
S DIR("?",1)="Answer 'Y' if patient or their representative is picking up the document in person.",DIR("?")="Answer 'N' if document is being mailed."
D ^DIR
I Y Q:'$$DIE("500////Y;501:503",2) I $D(Y) S ACHDXIT="" Q
Q
;
;EP - Denial Issued.
Q:'$$DIE("504:505",2)
I $D(Y) S ACHDXIT="" D END Q
Q
;
DEFPO ; --- Service Provided on PO.
Q:'$$DIE("506:507",2)
I $D(Y) S ACHDXIT="" Q
Q
;
END ;
D:'$D(ACHDXIT) ^ACHSDFDP ;DISPLAY DOCUMENT INFO
; IF NO EXIT THEN
I '$D(ACHDXIT),'$D(DUOUT) D NUMBER^ACHSDF1 ;SET THE DEFERRED SERVICE
; NUMBER AND POST THE
; DOCUMENT
K ACHDXIT
Q
;
DOCNTL1 ;EP - CALLED FROM OPTION 'ACHS DEF DOCNTL' Enter Document Control Info
D SETCK^ACHSDF1 ;CLEAR PHONY DOCUMENTS
N ACHSA,DA,DIC,DIE
W !!
S DIC="^ACHSDEF("_DUZ(2)_",""D"",",DA(1)=DUZ(2),DIC(0)="AQEM"
D ^DIC
Q:Y<1
S ACHSA=+Y
I $$DIE("500////Y;501:503",2)
Q
;
DENIAL ;EP - CALLED FROM OPTION 'ACHS DEN INFO' Enter Denial Info
D SETCK^ACHSDF1 ;CLEAR PHONY DOCUMENTS
N ACHSA,DA,DIC,DIE
W !!
S DIC="^ACHSDEF("_DUZ(2)_",""D"",",DA(1)=DUZ(2),DIC(0)="AQEM"
D ^DIC
Q:Y<1
S ACHSA=+Y
I $$DIE("504;505",2)
Q
;
PO ;EP - CALLED FROM OPTION 'ACHS DEF PO' Enter Purchase Order Info
D SETCK^ACHSDF1 ;CLEAR PHONY DOCUMENTS
N ACHSA,DA,DIC,DIE
W !!
S DIC="^ACHSDEF("_DUZ(2)_",""D"",",DA(1)=DUZ(2),DIC(0)="AEQM"
D ^DIC
Q:Y<1
S ACHSA=+Y
I $$DIE("506;507",2)
Q
;
DIE(DR,Z) ;EP --- Edit Deferred Service
I $G(Z) F %=1:1:Z W !
S DIE="^ACHSDEF("_DUZ(2)_",""D"","
S DA(1)=DUZ(2)
S DA=ACHSA
S AUPNLK("INAC")=""
S ACHDALL=1
;S DIC("S")="I $D(^AUPNPAT(Y,41,DUZ(2)))"
;
;S DIC("W")="I $D(^AUPNPAT(Y,41,DUZ(2)))"
;
I '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","+") S DUOUT="" Q 0
D ^DIE I $D(Y) S ACHDXIT=""
I '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","-") S DUOUT="" Q 0
Q 1
;
DIEPWN() ;ITSC/SET/JVK ADD FOR ACHS*3.1*12 IHS/OKCAO/POC PAWNEE BEN PKG
N PBEXDT,DFN,DUZSAVE
S DIC=1808000,DIC(0)="IQAZEM" S:$D(DFN) DIC("B")=$P($G(^DPT(DFN,0)),U)
D ^DIC K DIC
I $D(DUOUT)!($D(DTOUT))!(+Y<0) Q 0
S DFN=+Y
;ACHS*3.1*15 1.26.2009 IHS/OIT/FCJ ADDED $ IN FRONT OF THE P($G TO THE NEXT LINE
S PBEXDT=+$P($G(^AZOPBPP(+Y,0)),U,3),Y=PBEXDT X ^DD("DD")
I PBEXDT<DT W !!,*7,"PBPP Eligibility Card Expired on ",Y Q 0
F %=1:1:2 W !
S DIE="ACHSDEF("_DUZ(2)_",""D"","
S DA(1)=DUZ(2)
S DA=ACHSA
S AUPNLK("INAC")=""
S DUZSAVE=DUZ(2),DUZ(2)=0
S ACHDALL=1
I '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","+") S DUOUT="" Q 0
S DFN="`"_DFN
S DR="6///^S X=DFN" D DIE I $D(Y) S ACHDXIT=""
S DUZ(2)=DUZSAVE
I '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","-") S DUOUT="" Q 0
Q 1
ACHSDF ; IHS/ITSC/PMF - UNMET NEEDS DATA ENTRY (1/2) ; [ 03/24/2005 8:22 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUN 11, 2001;Build 43
+2 ;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
+3 ;
+4 ;SET UP SITE PARAMETERS
DO SETCK^ACHSDF1
+5 IF $GET(ACHDXQT)
QUIT
START ; --- Set Temporary Number.
+1 IF $DATA(^ACHSDEF(DUZ(2),"D",0))=0
SET ^ACHSDEF(DUZ(2),"D",0)="^9002066.01A^0^0"
+2 SET DIC="^ACHSDEF("_DUZ(2)_",""D"","
+3 SET DA(1)=DUZ(2)
+4 SET DIC(0)="L"
+5 SET X="#"_$PIECE($HOROLOG,",",1)_"#"_$PIECE($HOROLOG,",",2)
+6 DO ^DIC
+7 IF +Y<1
SET ACHDXIT=""
DO END
QUIT
+8 SET ACHSA=+Y
+9 ;
+10 ;FORCE ENTER 'DATE OF SERVICE' AND 'ISSUED BY'
+11 IF '$$DIE("2////"_DT_";3////"_DUZ,2)
SET ACHDXIT=""
DO END
QUIT
+12 DO PAT
+13 IF X[U
QUIT
+14 DO END
+15 QUIT
+16 ;
PAT ; --- Is Patient Registered.
+1 KILL DQ
+2 IF '$$DIE("5//Y",2)
QUIT
+3 IF $DATA(Y)
SET ACHDXIT=""
QUIT
+4 IF $$DF^ACHS(0,5)="N"
GOTO PATNOT
+5 ;
+6 ;ITSC/SET/JVK ACHS*3.1*12 ADD CHANGES FOR IHS/OKCAO/POC PAWNEE BEN PKG
+7 ;Q:'$$DIE(6,2)
+8 ;I +$P($G(^AUTTLOC(DUZ(2),0)),U,10)=505613 Q:'$$DIEPWN ;ACHS*3.1*18 3.12.2010 IHS.OIT.FCJ ADDED ACHSDXIT TST
+9 IF +$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,10)=505613
IF ('$$DIEPWN)!(ACHDXIT)
QUIT Q
+10 IF '$TEST
IF '$$DIE(6,2)
QUIT
+11 ;ITSC/SET/JVK END CHANGES ACHS*3.1*12
+12 IF $DATA(Y)
SET ACHDXIT=""
QUIT
+13 IF '$$DF^ACHS(0,6)
WRITE !,*7,"A Patient Name Must Be Entered",!!
GOTO PAT
+14 DO USER
+15 QUIT
+16 ;
PATNOT ; --- Patient not on file.
+1 KILL DQ
+2 IF '$$DIE("7
QUIT
+3 IF $DATA(Y)
GOTO PAT
+4 IF '$LENGTH($$DF^ACHS(0,7))
WRITE !,*7,"A Patient Name Must Be Entered",!!
GOTO PAT
+5 DO USER
+6 QUIT
+7 ;
USER ; --- Set variables to file.
+1 IF '$$DIE("3////"_DUZ)
QUIT
+2 IF $DATA(Y)
SET ACHDXIT=""
QUIT
+3 DO ISSDT
+4 QUIT
+5 ;
ISSDT ; --- Issue Date.
+1 IF '$$DIE("2////"_DT)
QUIT
+2 IF $DATA(Y)
SET ACHDXIT=""
QUIT
+3 DO REQ
+4 QUIT
+5 ;
REQ ; --- Date Request Received.
+1 IF '$$DIE(4,2)
QUIT
+2 IF $DATA(Y)
SET ACHDXIT=""
QUIT
+3 IF '$$DF^ACHS(0,4)
WRITE !,*7,"A Date Received Request Must Be Entered"
GOTO REQ
+4 DO DEFCAT
+5 QUIT
+6 ;
DEFCAT ; --- Deferred Service Category.
+1 WRITE !!
+2 ;{ABK,7/9/10}S DIC="^ACHSDFC(",DIC(0)="QAEM",DIC("A")="Enter Deferred Service Category: "
+3 SET DIC="^ACHSDFC("
SET DIC(0)="QAEM"
SET DIC("A")="Enter Unmet Need Category: "
+4 DO ^DIC
+5 IF X=U
QUIT
+6 ;{ABK,7/9/10}I Y<0 W *7,!!,"Must Have Deferred Services Category",! G DEFCAT
+7 IF Y<0
WRITE *7,!!,"Must Have Unmet Need Category",!
GOTO DEFCAT
+8 SET ACHDCAT=+Y
+9 IF '$$DIE("100////"_ACHDCAT)
QUIT
+10 ;
DEFSUB ; --- Deferred Service Subcategory
+1 WRITE !!
+2 ;{ABK,7/9/10}S DIC="^ACHSDFC("_ACHDCAT_",1,",DIC(0)="AQEM",DIC("A")="Enter Deferred Service Subcategory: "
+3 SET DIC="^ACHSDFC("_ACHDCAT_",1,"
SET DIC(0)="AQEM"
SET DIC("A")="Enter Unmet Need Subcategory: "
+4 DO ^DIC
+5 IF X=U
QUIT
+6 ;{ABK,7/9/10}I Y<0 W *7,!!,"Must Have Deferred Service Subcategory",! G DEFSUB
+7 IF Y<0
WRITE *7,!!,"Must Have Unmet Need Subcategory",!
GOTO DEFSUB
+8 SET ACHDSUB=+Y
+9 IF '$$DIE("105////"_ACHDSUB)
QUIT
+10 IF '$$DIE("110
QUIT
+11 IF $DATA(Y)
GOTO DEFCAT
+12 DO DEFDIAG
+13 QUIT
+14 ;
DEFDIAG ; --- Deferred Service Diagnosis.
+1 IF $$DF^ACHS(100,2)="O"
GOTO DEFPROC
+2 IF '$$DIE(200,2)
QUIT
+3 IF $DATA(Y)
SET ACHDXIT=""
QUIT
+4 ;ACHS*3.1*23 CHG ICD9 TO ICD IN NXT LINE
+5 IF '$DATA(^ACHSDEF(DUZ(2),"D",ACHSA,200,0))
WRITE !,*7,"An ICD Diagnosis Code Must Be Entered",!!
GOTO DEFDIAG
+6 DO DEFCMT
+7 QUIT
+8 ;
DEFPROC ; --- Deferred Service CPT.
+1 IF '$$DIE(300,2)
QUIT
+2 IF $DATA(Y)
SET ACHDXIT=""
QUIT
+3 IF '$DATA(^ACHSDEF(DUZ(2),"D",ACHSA,300,0))
WRITE !,*7,"A CPT Procedure Code Must Be Entered",!!
GOTO DEFPROC
+4 DO DEFCMT
+5 QUIT
+6 ;
DEFCMT ; --- Comment.
+1 IF '$$DIE(400,2)
QUIT
+2 IF $DATA(Y)
SET ACHDXIT=""
QUIT
+3 DO DEFDCT
+4 QUIT
+5 ;
DEFDCT ; --- Document Control.
+1 WRITE !!
+2 KILL DIR
+3 SET DIR(0)="Y"
SET DIR("A")="Enter Document Control Information Now"
SET DIR("B")="NO"
+4 SET DIR("?",1)="Answer 'Y' if patient or their representative is picking up the document in person."
SET DIR("?")="Answer 'N' if document is being mailed."
+5 DO ^DIR
+6 IF Y
IF '$$DIE("500////Y;501
QUIT
IF $DATA(Y)
SET ACHDXIT=""
QUIT
+7 QUIT
+8 ;
+9 ;EP - Denial Issued.
+10 IF '$$DIE("504
QUIT
+11 IF $DATA(Y)
SET ACHDXIT=""
DO END
QUIT
+12 QUIT
+13 ;
DEFPO ; --- Service Provided on PO.
+1 IF '$$DIE("506
QUIT
+2 IF $DATA(Y)
SET ACHDXIT=""
QUIT
+3 QUIT
+4 ;
END ;
+1 ;DISPLAY DOCUMENT INFO
IF '$DATA(ACHDXIT)
DO ^ACHSDFDP
+2 ; IF NO EXIT THEN
+3 ;SET THE DEFERRED SERVICE
IF '$DATA(ACHDXIT)
IF '$DATA(DUOUT)
DO NUMBER^ACHSDF1
+4 ; NUMBER AND POST THE
+5 ; DOCUMENT
+6 KILL ACHDXIT
+7 QUIT
+8 ;
DOCNTL1 ;EP - CALLED FROM OPTION 'ACHS DEF DOCNTL' Enter Document Control Info
+1 ;CLEAR PHONY DOCUMENTS
DO SETCK^ACHSDF1
+2 NEW ACHSA,DA,DIC,DIE
+3 WRITE !!
+4 SET DIC="^ACHSDEF("_DUZ(2)_",""D"","
SET DA(1)=DUZ(2)
SET DIC(0)="AQEM"
+5 DO ^DIC
+6 IF Y<1
QUIT
+7 SET ACHSA=+Y
+8 IF $$DIE("500////Y;501:503",2)
+9 QUIT
+10 ;
DENIAL ;EP - CALLED FROM OPTION 'ACHS DEN INFO' Enter Denial Info
+1 ;CLEAR PHONY DOCUMENTS
DO SETCK^ACHSDF1
+2 NEW ACHSA,DA,DIC,DIE
+3 WRITE !!
+4 SET DIC="^ACHSDEF("_DUZ(2)_",""D"","
SET DA(1)=DUZ(2)
SET DIC(0)="AQEM"
+5 DO ^DIC
+6 IF Y<1
QUIT
+7 SET ACHSA=+Y
+8 IF $$DIE("504;505",2)
+9 QUIT
+10 ;
PO ;EP - CALLED FROM OPTION 'ACHS DEF PO' Enter Purchase Order Info
+1 ;CLEAR PHONY DOCUMENTS
DO SETCK^ACHSDF1
+2 NEW ACHSA,DA,DIC,DIE
+3 WRITE !!
+4 SET DIC="^ACHSDEF("_DUZ(2)_",""D"","
SET DA(1)=DUZ(2)
SET DIC(0)="AEQM"
+5 DO ^DIC
+6 IF Y<1
QUIT
+7 SET ACHSA=+Y
+8 IF $$DIE("506;507",2)
+9 QUIT
+10 ;
DIE(DR,Z) ;EP --- Edit Deferred Service
+1 IF $GET(Z)
FOR %=1:1:Z
WRITE !
+2 SET DIE="^ACHSDEF("_DUZ(2)_",""D"","
+3 SET DA(1)=DUZ(2)
+4 SET DA=ACHSA
+5 SET AUPNLK("INAC")=""
+6 SET ACHDALL=1
+7 ;S DIC("S")="I $D(^AUPNPAT(Y,41,DUZ(2)))"
+8 ;
+9 ;S DIC("W")="I $D(^AUPNPAT(Y,41,DUZ(2)))"
+10 ;
+11 IF '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","+")
SET DUOUT=""
QUIT 0
+12 DO ^DIE
IF $DATA(Y)
SET ACHDXIT=""
+13 IF '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","-")
SET DUOUT=""
QUIT 0
+14 QUIT 1
+15 ;
DIEPWN() ;ITSC/SET/JVK ADD FOR ACHS*3.1*12 IHS/OKCAO/POC PAWNEE BEN PKG
+1 NEW PBEXDT,DFN,DUZSAVE
+2 SET DIC=1808000
SET DIC(0)="IQAZEM"
IF $DATA(DFN)
SET DIC("B")=$PIECE($GET(^DPT(DFN,0)),U)
+3 DO ^DIC
KILL DIC
+4 IF $DATA(DUOUT)!($DATA(DTOUT))!(+Y<0)
QUIT 0
+5 SET DFN=+Y
+6 ;ACHS*3.1*15 1.26.2009 IHS/OIT/FCJ ADDED $ IN FRONT OF THE P($G TO THE NEXT LINE
+7 SET PBEXDT=+$PIECE($GET(^AZOPBPP(+Y,0)),U,3)
SET Y=PBEXDT
XECUTE ^DD("DD")
+8 IF PBEXDT<DT
WRITE !!,*7,"PBPP Eligibility Card Expired on ",Y
QUIT 0
+9 FOR %=1:1:2
WRITE !
+10 SET DIE="ACHSDEF("_DUZ(2)_",""D"","
+11 SET DA(1)=DUZ(2)
+12 SET DA=ACHSA
+13 SET AUPNLK("INAC")=""
+14 SET DUZSAVE=DUZ(2)
SET DUZ(2)=0
+15 SET ACHDALL=1
+16 IF '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","+")
SET DUOUT=""
QUIT 0
+17 SET DFN="`"_DFN
+18 SET DR="6///^S X=DFN"
DO DIE
IF $DATA(Y)
SET ACHDXIT=""
+19 SET DUZ(2)=DUZSAVE
+20 IF '$$LOCK^ACHS("^ACHSDEF(DUZ(2),""D"",ACHSA)","-")
SET DUOUT=""
QUIT 0
+21 QUIT 1
