ACHSDFLK ; IHS/ITSC/PMF - DEFERRAL LOOKUP ; [ 04/19/2002 9:30 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUN 11, 2001
;ACHS*3.1*4 whole routine is new for this patch
;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
;
K ACHDLKER,DFN
S DIWL=5,DIWR=75,DIWF="W"
N DONE S DONE=0
;
;keep asking them for a deferral until we get DONE
;DONE can mean we got one, or we are ready to quit
F D Q:DONE
. D GETDEF
. I $D(ACHDLKER) S DONE=1 Q
. I ACHSA="" S (ACHDLKER,DONE)=1 Q
. D PP
. Q
;
K DIC
Q
;
;
GETDEF ;get a deferral, either by number or by patient
W !!
K DFN,DIC,Y S ACHSA=""
;{ABK, 3/31/10}S DIR("A")="Enter the DEFERRAL NUMBER or PATIENT"
;{ABK, 3/31/10}S DIR("?")="Enter either the deferral number or a Patient Identifier (Name, HRN, SSN, DOB)"
S DIR("A")="Enter the UNMET NEED NUMBER or PATIENT"
S DIR("?")="Enter either the unmet need number or a Patient Identifier (Name, HRN, SSN, DOB)"
S DIR(0)="FO" D ^DIR K DIR
;
;now the responses. if quit, quit.
Q:$D(DIRUT)
;
;see if the input is a real, full deferral case number
;if so, X will not be null after this
S X="",X=$O(^ACHSDEF(DUZ(2),"D","B",Y,""))
;
;if they entered a blank space or a deferral number, use
;^DIC to load info
I Y=" "!X S X="" D GETDEF2("EMZ",Y) Q:ACHSA'="" W " ","??" G GETDEF
;
;first, try patient lookup for registered patients
S X=Y,DIC="^AUPNPAT(",DIC(0)="EM",AUPNLK("ALL")=1
D ^DIC
;
;if that didn't work, try looking up unregistered patients
;if it works, stop, if it doesn't go back to the top
I +Y<0 D Q:ACHSA'="" W " ","??" G GETDEF
. D GETDEF2("EMZ",X)
. ;I +Y<1 S ACHDLKER="" G END
. ;S ACHSA=+Y
;
;if we DID find a registered patient, submit that and get deferral
S PATDAT=$G(^DPT(+Y,0))
I PATDAT="" G GETDEF
D GETDEF2("EMZ",$P(PATDAT,U,1))
I +Y<0 W " ","??" G GETDEF
S ACHSA=+Y
;
Q
;
GETDEF2(DIC0,X) ;
;use ^DIC to get a deferral case.
;input: DIC0 the value to give DIC(0)
; X the input value for ^DIC, not manditory
S X=$G(X)
K DIC
S DIC="^ACHSDEF("_DUZ(2)_",""D"","
S DIC(0)=DIC0
;{ABK, 3/31/10}S DIC("A")="Enter the deferral NUMBER or PATIENT: "
S DIC("A")="Enter the unmet need NUMBER or PATIENT: "
S DIC("S")="I $P($G(^(0)),U)'[""#"""
S DA(1)=DUZ(2)
;
;3/28/02 pmf experimenting with DIC("W")
S DIC("W")="W $E($P(^(0),U,2),4,5),""/"",$E($P(^(0),U,2),6,7),""/"",($E($P(^(0),U,2),1,3)+1700)"
;
D ^DIC
Q:+Y<0
S ACHSA=+Y
Q
;
PP ;
S Y(0)=$G(Y(0))
G P0:$P(Y(0),U,5)'="Y"!($P(Y(0),U,6)']"")
G P0:'$D(^DPT($P(Y(0),U,6),0))
S DFN=$P(Y(0),U,6)
G P1
;
P0 ;
I $P(Y(0),U,7)="" G NAMERR
;
P1 ;
W !!,"You have chosen "_ACHDOCT_" document ",$P(Y(0),U),!!
G P2:'$D(DFN)
W $P($G(^DPT(DFN,0)),U),!
S A=$G(^DPT(DFN,.11))
W $P(A,U),!,$P(A,U,4)
S ACHDST=$P(A,U,5)
I ACHDST]"",$D(^DIC(5,ACHDST,0)) W " ",$P($G(^DIC(5,ACHDST,0)),U,2)
W " ",$P(A,U,6),!!
G P3
;
P2 ;
S A=$G(^ACHSDEF(DUZ(2),"D",ACHSA,10))
W $P(A,U),!,$P(A,U,2),!,$P(A,U,3)
S ACHDST=$P(A,U,4)
I ACHDST]"",$D(^DIC(5,ACHDST,0)) W " ",$P($G(^DIC(5,ACHDST,0)),U,2)
W " ",$P(A,U,5),!!
P3 ;
W "Date of service ",$$FMTE^XLFDT($$DN^ACHS(0,4)),!!
S %=$$DIR^ACHS("Y","Is this correct","YES","Did you select the correct document?","",2)
I $D(DTOUT)!$D(DUOUT) S ACHDLKER="",DONE=1
I % S DONE=1
Q
;
NAMERR ;
W !!,*7,"No valid PATIENT NAME in this file.",!,"No letter may be printed until a valid patient is entered.",!!
Q
;
ACHSDFLK ; IHS/ITSC/PMF - DEFERRAL LOOKUP ; [ 04/19/2002 9:30 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUN 11, 2001
+2 ;ACHS*3.1*4 whole routine is new for this patch
+3 ;ACHS*3.1*18 4/1/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
+4 ;
+5 KILL ACHDLKER,DFN
+6 SET DIWL=5
SET DIWR=75
SET DIWF="W"
+7 NEW DONE
SET DONE=0
+8 ;
+9 ;keep asking them for a deferral until we get DONE
+10 ;DONE can mean we got one, or we are ready to quit
+11 FOR
Begin DoDot:1
+12 DO GETDEF
+13 IF $DATA(ACHDLKER)
SET DONE=1
QUIT
+14 IF ACHSA=""
SET (ACHDLKER,DONE)=1
QUIT
+15 DO PP
+16 QUIT
End DoDot:1
IF DONE
QUIT
+17 ;
+18 KILL DIC
+19 QUIT
+20 ;
+21 ;
GETDEF ;get a deferral, either by number or by patient
+1 WRITE !!
+2 KILL DFN,DIC,Y
SET ACHSA=""
+3 ;{ABK, 3/31/10}S DIR("A")="Enter the DEFERRAL NUMBER or PATIENT"
+4 ;{ABK, 3/31/10}S DIR("?")="Enter either the deferral number or a Patient Identifier (Name, HRN, SSN, DOB)"
+5 SET DIR("A")="Enter the UNMET NEED NUMBER or PATIENT"
+6 SET DIR("?")="Enter either the unmet need number or a Patient Identifier (Name, HRN, SSN, DOB)"
+7 SET DIR(0)="FO"
DO ^DIR
KILL DIR
+8 ;
+9 ;now the responses. if quit, quit.
+10 IF $DATA(DIRUT)
QUIT
+11 ;
+12 ;see if the input is a real, full deferral case number
+13 ;if so, X will not be null after this
+14 SET X=""
SET X=$ORDER(^ACHSDEF(DUZ(2),"D","B",Y,""))
+15 ;
+16 ;if they entered a blank space or a deferral number, use
+17 ;^DIC to load info
+18 IF Y=" "!X
SET X=""
DO GETDEF2("EMZ",Y)
IF ACHSA'=""
QUIT
WRITE " ","??"
GOTO GETDEF
+19 ;
+20 ;first, try patient lookup for registered patients
+21 SET X=Y
SET DIC="^AUPNPAT("
SET DIC(0)="EM"
SET AUPNLK("ALL")=1
+22 DO ^DIC
+23 ;
+24 ;if that didn't work, try looking up unregistered patients
+25 ;if it works, stop, if it doesn't go back to the top
+26 IF +Y<0
Begin DoDot:1
+27 DO GETDEF2("EMZ",X)
+28 ;I +Y<1 S ACHDLKER="" G END
+29 ;S ACHSA=+Y
End DoDot:1
IF ACHSA'=""
QUIT
WRITE " ","??"
GOTO GETDEF
+30 ;
+31 ;if we DID find a registered patient, submit that and get deferral
+32 SET PATDAT=$GET(^DPT(+Y,0))
+33 IF PATDAT=""
GOTO GETDEF
+34 DO GETDEF2("EMZ",$PIECE(PATDAT,U,1))
+35 IF +Y<0
WRITE " ","??"
GOTO GETDEF
+36 SET ACHSA=+Y
+37 ;
+38 QUIT
+39 ;
GETDEF2(DIC0,X) ;
+1 ;use ^DIC to get a deferral case.
+2 ;input: DIC0 the value to give DIC(0)
+3 ; X the input value for ^DIC, not manditory
+4 SET X=$GET(X)
+5 KILL DIC
+6 SET DIC="^ACHSDEF("_DUZ(2)_",""D"","
+7 SET DIC(0)=DIC0
+8 ;{ABK, 3/31/10}S DIC("A")="Enter the deferral NUMBER or PATIENT: "
+9 SET DIC("A")="Enter the unmet need NUMBER or PATIENT: "
+10 SET DIC("S")="I $P($G(^(0)),U)'[""#"""
+11 SET DA(1)=DUZ(2)
+12 ;
+13 ;3/28/02 pmf experimenting with DIC("W")
+14 SET DIC("W")="W $E($P(^(0),U,2),4,5),""/"",$E($P(^(0),U,2),6,7),""/"",($E($P(^(0),U,2),1,3)+1700)"
+15 ;
+16 DO ^DIC
+17 IF +Y<0
QUIT
+18 SET ACHSA=+Y
+19 QUIT
+20 ;
PP ;
+1 SET Y(0)=$GET(Y(0))
+2 IF $PIECE(Y(0),U,5)'="Y"!($PIECE(Y(0),U,6)']"")
GOTO P0
+3 IF '$DATA(^DPT($PIECE(Y(0),U,6),0))
GOTO P0
+4 SET DFN=$PIECE(Y(0),U,6)
+5 GOTO P1
+6 ;
P0 ;
+1 IF $PIECE(Y(0),U,7)=""
GOTO NAMERR
+2 ;
P1 ;
+1 WRITE !!,"You have chosen "_ACHDOCT_" document ",$PIECE(Y(0),U),!!
+2 IF '$DATA(DFN)
GOTO P2
+3 WRITE $PIECE($GET(^DPT(DFN,0)),U),!
+4 SET A=$GET(^DPT(DFN,.11))
+5 WRITE $PIECE(A,U),!,$PIECE(A,U,4)
+6 SET ACHDST=$PIECE(A,U,5)
+7 IF ACHDST]""
IF $DATA(^DIC(5,ACHDST,0))
WRITE " ",$PIECE($GET(^DIC(5,ACHDST,0)),U,2)
+8 WRITE " ",$PIECE(A,U,6),!!
+9 GOTO P3
+10 ;
P2 ;
+1 SET A=$GET(^ACHSDEF(DUZ(2),"D",ACHSA,10))
+2 WRITE $PIECE(A,U),!,$PIECE(A,U,2),!,$PIECE(A,U,3)
+3 SET ACHDST=$PIECE(A,U,4)
+4 IF ACHDST]""
IF $DATA(^DIC(5,ACHDST,0))
WRITE " ",$PIECE($GET(^DIC(5,ACHDST,0)),U,2)
+5 WRITE " ",$PIECE(A,U,5),!!
P3 ;
+1 WRITE "Date of service ",$$FMTE^XLFDT($$DN^ACHS(0,4)),!!
+2 SET %=$$DIR^ACHS("Y","Is this correct","YES","Did you select the correct document?","",2)
+3 IF $DATA(DTOUT)!$DATA(DUOUT)
SET ACHDLKER=""
SET DONE=1
+4 IF %
SET DONE=1
+5 QUIT
+6 ;
NAMERR ;
+1 WRITE !!,*7,"No valid PATIENT NAME in this file.",!,"No letter may be printed until a valid patient is entered.",!!
+2 QUIT
+3 ;
