AMER2B ; IHS/ANMC/GIS - COST RECOVERY DATA RELATED TO INJURIES ;
;;3.0;ER VISIT SYSTEM;**6,7**;MAR 03, 2009;Build 5
;
QD31 ; CITY OF INJURY
S DIR("B")=$G(^TMP("AMER",$J,2,31))
S DIR(0)="FO^1:30",DIR("A")="Town/village where injury occurred" KILL DA D ^DIR KILL DIR
D CKSC^AMER1 I $D(AMERCKSC) K AMERCKSC G QD31
;
;AMER*3.0*6;Added call to update BEDD
NEW INJ
I Y'["^" S INJ=Y D
. NEW Y
. D INJ^AMERBEDD("INJ.PtInjury.InjLocat",INJ)
K INJ
;
D OUT^AMER
Q
;
QD32 ; TIME OF INJURY
I $D(^TMP("AMER",$J,2,32)) S Y=^(32) X ^DD("DD") S DIR("B")=Y
S DIR(0)="DO^::ER",DIR("A")="Enter the exact time and date of injury",DIR("?")="Enter a time and date in the usual FileMan format (e.g., 1/3/90@1PM)." D ^DIR K DIR
I Y,$$TCK^AMER2A($G(^TMP("AMER",$J,1,2)),Y,0,"admission") K Y G QD32
I Y="" S Y=-1
;
;AMER*3.0*6;Added call to update BEDD
NEW INJ
I Y'["^" S INJ=Y D
. NEW Y
. D INJ^AMERBEDD("INJ.PtInjury.InjDtTm",INJ)
K INJ
;
D OUT^AMER
Q
;
QD33(AMERPCC,DTOUT) ; CAUSE OF INJURY
;
;Input
; AMERPCC - Visit IEN (optional)
; DFN - Needs to be defined
;
;Returns DTOUT on timeouts
;
NEW DIR,DUOUT,DIRUT,DIROUT,INP,VDT,LEX,QUIT,SELECT,TOTREC,SEX,RET
NEW CAUSE,EDIT
I $G(AMERPCC)="" S AMERPCC=$$GET1^DIQ(9009081,DFN_",",1.1,"I")
I AMERPCC]"" S VDT=$P($$GET1^DIQ(9000010,AMERPCC,.01,"I"),".")
S:$G(VDT)="" VDT=DT
S SEX=$$GET1^DIQ(2,DFN_",",.02,"I")
;
;Get the current cause of injury
I $G(AMERDA)]"" S CAUSE=$$GET1^DIQ(9009080,AMERDA_",",3.2,"I")
I $G(CAUSE)="" S CAUSE=$G(^TMP("AMER",$J,2,33))
;
;If current value, display and check for edit
S EDIT="" I CAUSE]"" D I 'EDIT G XQD33
. NEW DESC,DIR,DUOUT,DTOUT
. ;
. ;Get the current display value
. S DESC=$$DX^AMERPOV(CAUSE,"",1,VDT) Q:DESC=""
. W !!,"Current Cause of injury: ",DESC,!
. S DIR("B")="NO"
. S DIR(0)="YO",DIR("A")="Change cause of injury to new value"
. D ^DIR
. I Y=1 S EDIT=1 Q
. ;
. ;Process timeouts and "^"
. I $D(DUOUT) S (X,Y)="^" Q
. I $D(DTOUT) S (X,Y)="^" Q
. ;
. ;Do not change - plug in current value
. S Y=CAUSE Q
;
QD33E S DIR(0)="F^3"
;S (X,Y)=""
S DIR("A")="*Cause of injury"
S DIR("?")="Enter a string or ICD code for the Cause of Injury"
D ^DIR
I $D(DIRUT) S X="^" Q
;
;Perform the lookup
;
;Call parameters
;P1-Search Text, P2-Return Count, P3-Search Type (0-No COI, 1-Only COI, 2-All),P4-Date,P5-Gender
;S INP=Y_"^1^"_VDT_"^"_SEX_"^2^0"
D LEX^AMERUTIL(Y,100,1,VDT,SEX,.RET)
;
;Reprompt if no results
I $O(RET(""))="" W !!,"<No results returned. Please try a different search string>",! H 2 K RET G QD33E
;
;Convert results to ICD
K ^TMP("AMERICD",$J)
S TOTREC=0,LEX="" F S LEX=$O(RET(LEX)) Q:LEX="" I +LEX S TOTREC=TOTREC+1,^TMP("AMERICD",$J,TOTREC)=RET(LEX)
;
;Display Results
S SELECT=""
W !!
S (QUIT,LEX)=0 F S LEX=$O(^TMP("AMERICD",$J,LEX)) Q:LEX="" D Q:QUIT>1 Q:SELECT]""
. ;
. NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,ND
. ;
. ;Display one entry
. S ND=$G(^TMP("AMERICD",$J,LEX)) Q:$TR(ND,"^")=""
. W !,LEX,?4,$P(ND,U,2),?14,$E($P(ND,U,3),1,64)
. ;
. ;Prompt every 5 entries
. I LEX#5'=0,LEX'=+TOTREC Q
. W !,"Press <RETURN> to see more, '^' to exit this list, OR"
. S DIR("A")="CHOOSE 1-"_LEX_": "
. S DIR(0)="NOA^1:"_LEX
. D ^DIR
. S QUIT=$$CKANS() Q:QUIT
. ;
. ;Record the selection
. S:+Y SELECT=+Y
;
;Handle "^", "^^", timeouot
I QUIT=2 K RET G QD33E
I QUIT=3 S (Y,X)="^" Q
I SELECT="" K RET G QD33E
;
;Set entry
S Y=$P($G(^TMP("AMERICD",$J,+SELECT)),U)
;
;AMER*3.0*6;Added call to update BEDD
NEW INJ
;AMER*3.0*7;Added in DO
;I Y'["^" S INJ=Y
I Y'["^" S INJ=Y D
. NEW Y
. D INJ^AMERBEDD("INJ.PtInjury.InjCauseIEN",INJ)
K INJ
;
XQD33 D OUT^AMER
Q
;
QD34 ; PLACE OF INJURY
S DIC("A")="Setting of accident/injury: " K DIC("B")
I $D(^TMP("AMER",$J,2,34)) S %=+^(34) S:%>0 DIC("B")=$P(^AMER(3,%,0),U)
S DIC="^AMER(3,",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("SCENE OF INJURY"),DIC(0)="AEQ"
D ^DIC K DIC S Y=+Y
;
;AMER*3.0*6;Added call to update BEDD
NEW INJ
;AMER*3.0*7;Added in DO
;I +Y>0 S INJ=Y
I +Y>0 S INJ=Y D
. NEW Y
. D INJ^AMERBEDD("INJ.PtInjury.InjSet",INJ)
K INJ
;
D OUT^AMER
;
;No longer in use
;S Z=U,%="MOTOR VEHICLE^BICYCLE^TOOLS JOB EQUIP.^INHILATION (GAS/SMOKE)^CHEMICALS (CAUSTIC OR TOXIC)^ELECTRICITY^FIRE FLAME^FALL (ACCIDENTAL)" F I=1:1:$L(%,U) S A=$P(%,U,I),Z=Z_+$O(^AMER(3,"B",A,0))_U
;S %=$P($G(^TMP("AMER",$J,2,33)),U) I Z'[(U_%_U) G QD35A ; SAFETY EQUIP NOT RELEVANT
Q
;
QD35 ; SAFETY EQUIPMENT OF INJURY
N A,Z,%
S DIC("A")="Safety equipment used: " K DIC("B")
I $D(^TMP("AMER",$J,2,35)) S %=+^(35) S:%>0 DIC("B")=$P(^AMER(3,%,0),U)
S DIC="^AMER(3,",DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("SAFETY EQUIPMENT"),DIC(0)="AEQ"
D ^DIC K DIC S Y=+Y
;
;AMER*3.0*6;Added call to update BEDD
NEW INJ
;AMER*3.0*7;Added in DO
;I +Y>0 S INJ=Y
I +Y>0 S INJ=Y D
. NEW Y
. D INJ^AMERBEDD("INJ.PtInjury.SafetyEquip",INJ)
K INJ
;
D OUT^AMER I $D(AMERQUIT) Q
QD35A ;
;
NEW MVA
;
S MVA=""
;
;Look for MVA
I $G(AMERDFN)]"" D
. NEW DESC,%,I
. S %=$P($G(^TMP("AMER",$J,2,33)),U)
. S DESC=$$DESC(%,AMERDFN,"","")
. F I="MOTOR","VEH","MV","TRAFFIC" I $$UP^XLFSTR(DESC)[I S MVA=1
;
;If MVA ask additional questions
I MVA=1 D Q ; MVA
. S AMERRUN=40
. F I=61:1:64 K ^TMP("AMER",$J,2,I) ; MVA
. Q
;
;Not a MVA
F I=41:1:46,51:1:57,61:1:64 K ^TMP("AMER",$J,2,I)
I $D(AMEREFLG) S AMERRUN=99
E S AMERRUN=4
Q
;
QD41 ; DESCIPTION OF MVA LOCATION
K DIR("B") I $D(^TMP("AMER",$J,2,41)) S DIR("B")=^(41)
S DIR(0)="FO^1:100",DIR("A")="Location of MVC (if applicable)",DIR("?")="Enter free text location description (100 characters max.)" D ^DIR K DIR
D CKSC^AMER1 I $D(AMERCKSC) K AMERCKSC G QD41
D OUT^AMER I $D(AMERQUIT) Q
S AMERRUN=4
Q
;
CKANS() ;EP - Check answer "^", "^^", and timeout
;
;User typed "^^"
I $G(DIROUT) Q 3
;
;User typed "^" or timed out
I $G(DUOUT)!$G(DTOUT) Q 2
;
;User hit ENTER
I $G(DIRUT) Q 1
;
Q 0
;
DESC(X,D0,CODE,VDATE) ;Return the ICD Description
;
NEW ICDDESC
;
;Make the call to get the string
S ICDDESC=$$DX^AMERPOV($G(X),$G(D0),$G(CODE),$G(VDATE))
Q ICDDESC
AMER2B ; IHS/ANMC/GIS - COST RECOVERY DATA RELATED TO INJURIES ;
+1 ;;3.0;ER VISIT SYSTEM;**6,7**;MAR 03, 2009;Build 5
+2 ;
QD31 ; CITY OF INJURY
+1 SET DIR("B")=$GET(^TMP("AMER",$JOB,2,31))
+2 SET DIR(0)="FO^1:30"
SET DIR("A")="Town/village where injury occurred"
KILL DA
DO ^DIR
KILL DIR
+3 DO CKSC^AMER1
IF $DATA(AMERCKSC)
KILL AMERCKSC
GOTO QD31
+4 ;
+5 ;AMER*3.0*6;Added call to update BEDD
+6 NEW INJ
+7 IF Y'["^"
SET INJ=Y
Begin DoDot:1
+8 NEW Y
+9 DO INJ^AMERBEDD("INJ.PtInjury.InjLocat",INJ)
End DoDot:1
+10 KILL INJ
+11 ;
+12 DO OUT^AMER
+13 QUIT
+14 ;
QD32 ; TIME OF INJURY
+1 IF $DATA(^TMP("AMER",$JOB,2,32))
SET Y=^(32)
XECUTE ^DD("DD")
SET DIR("B")=Y
+2 SET DIR(0)="DO^::ER"
SET DIR("A")="Enter the exact time and date of injury"
SET DIR("?")="Enter a time and date in the usual FileMan format (e.g., 1/3/90@1PM)."
DO ^DIR
KILL DIR
+3 IF Y
IF $$TCK^AMER2A($GET(^TMP("AMER",$JOB,1,2)),Y,0,"admission")
KILL Y
GOTO QD32
+4 IF Y=""
SET Y=-1
+5 ;
+6 ;AMER*3.0*6;Added call to update BEDD
+7 NEW INJ
+8 IF Y'["^"
SET INJ=Y
Begin DoDot:1
+9 NEW Y
+10 DO INJ^AMERBEDD("INJ.PtInjury.InjDtTm",INJ)
End DoDot:1
+11 KILL INJ
+12 ;
+13 DO OUT^AMER
+14 QUIT
+15 ;
QD33(AMERPCC,DTOUT) ; CAUSE OF INJURY
+1 ;
+2 ;Input
+3 ; AMERPCC - Visit IEN (optional)
+4 ; DFN - Needs to be defined
+5 ;
+6 ;Returns DTOUT on timeouts
+7 ;
+8 NEW DIR,DUOUT,DIRUT,DIROUT,INP,VDT,LEX,QUIT,SELECT,TOTREC,SEX,RET
+9 NEW CAUSE,EDIT
+10 IF $GET(AMERPCC)=""
SET AMERPCC=$$GET1^DIQ(9009081,DFN_",",1.1,"I")
+11 IF AMERPCC]""
SET VDT=$PIECE($$GET1^DIQ(9000010,AMERPCC,.01,"I"),".")
+12 IF $GET(VDT)=""
SET VDT=DT
+13 SET SEX=$$GET1^DIQ(2,DFN_",",.02,"I")
+14 ;
+15 ;Get the current cause of injury
+16 IF $GET(AMERDA)]""
SET CAUSE=$$GET1^DIQ(9009080,AMERDA_",",3.2,"I")
+17 IF $GET(CAUSE)=""
SET CAUSE=$GET(^TMP("AMER",$JOB,2,33))
+18 ;
+19 ;If current value, display and check for edit
+20 SET EDIT=""
IF CAUSE]""
Begin DoDot:1
+21 NEW DESC,DIR,DUOUT,DTOUT
+22 ;
+23 ;Get the current display value
+24 SET DESC=$$DX^AMERPOV(CAUSE,"",1,VDT)
IF DESC=""
QUIT
+25 WRITE !!,"Current Cause of injury: ",DESC,!
+26 SET DIR("B")="NO"
+27 SET DIR(0)="YO"
SET DIR("A")="Change cause of injury to new value"
+28 DO ^DIR
+29 IF Y=1
SET EDIT=1
QUIT
+30 ;
+31 ;Process timeouts and "^"
+32 IF $DATA(DUOUT)
SET (X,Y)="^"
QUIT
+33 IF $DATA(DTOUT)
SET (X,Y)="^"
QUIT
+34 ;
+35 ;Do not change - plug in current value
+36 SET Y=CAUSE
QUIT
End DoDot:1
IF 'EDIT
GOTO XQD33
+37 ;
QD33E SET DIR(0)="F^3"
+1 ;S (X,Y)=""
+2 SET DIR("A")="*Cause of injury"
+3 SET DIR("?")="Enter a string or ICD code for the Cause of Injury"
+4 DO ^DIR
+5 IF $DATA(DIRUT)
SET X="^"
QUIT
+6 ;
+7 ;Perform the lookup
+8 ;
+9 ;Call parameters
+10 ;P1-Search Text, P2-Return Count, P3-Search Type (0-No COI, 1-Only COI, 2-All),P4-Date,P5-Gender
+11 ;S INP=Y_"^1^"_VDT_"^"_SEX_"^2^0"
+12 DO LEX^AMERUTIL(Y,100,1,VDT,SEX,.RET)
+13 ;
+14 ;Reprompt if no results
+15 IF $ORDER(RET(""))=""
WRITE !!,"<No results returned. Please try a different search string>",!
HANG 2
KILL RET
GOTO QD33E
+16 ;
+17 ;Convert results to ICD
+18 KILL ^TMP("AMERICD",$JOB)
+19 SET TOTREC=0
SET LEX=""
FOR
SET LEX=$ORDER(RET(LEX))
IF LEX=""
QUIT
IF +LEX
SET TOTREC=TOTREC+1
SET ^TMP("AMERICD",$JOB,TOTREC)=RET(LEX)
+20 ;
+21 ;Display Results
+22 SET SELECT=""
+23 WRITE !!
+24 SET (QUIT,LEX)=0
FOR
SET LEX=$ORDER(^TMP("AMERICD",$JOB,LEX))
IF LEX=""
QUIT
Begin DoDot:1
+25 ;
+26 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,X,Y,ND
+27 ;
+28 ;Display one entry
+29 SET ND=$GET(^TMP("AMERICD",$JOB,LEX))
IF $TRANSLATE(ND,"^")=""
QUIT
+30 WRITE !,LEX,?4,$PIECE(ND,U,2),?14,$EXTRACT($PIECE(ND,U,3),1,64)
+31 ;
+32 ;Prompt every 5 entries
+33 IF LEX#5'=0
IF LEX'=+TOTREC
QUIT
+34 WRITE !,"Press <RETURN> to see more, '^' to exit this list, OR"
+35 SET DIR("A")="CHOOSE 1-"_LEX_": "
+36 SET DIR(0)="NOA^1:"_LEX
+37 DO ^DIR
+38 SET QUIT=$$CKANS()
IF QUIT
QUIT
+39 ;
+40 ;Record the selection
+41 IF +Y
SET SELECT=+Y
End DoDot:1
IF QUIT>1
QUIT
IF SELECT]""
QUIT
+42 ;
+43 ;Handle "^", "^^", timeouot
+44 IF QUIT=2
KILL RET
GOTO QD33E
+45 IF QUIT=3
SET (Y,X)="^"
QUIT
+46 IF SELECT=""
KILL RET
GOTO QD33E
+47 ;
+48 ;Set entry
+49 SET Y=$PIECE($GET(^TMP("AMERICD",$JOB,+SELECT)),U)
+50 ;
+51 ;AMER*3.0*6;Added call to update BEDD
+52 NEW INJ
+53 ;AMER*3.0*7;Added in DO
+54 ;I Y'["^" S INJ=Y
+55 IF Y'["^"
SET INJ=Y
Begin DoDot:1
+56 NEW Y
+57 DO INJ^AMERBEDD("INJ.PtInjury.InjCauseIEN",INJ)
End DoDot:1
+58 KILL INJ
+59 ;
XQD33 DO OUT^AMER
+1 QUIT
+2 ;
QD34 ; PLACE OF INJURY
+1 SET DIC("A")="Setting of accident/injury: "
KILL DIC("B")
+2 IF $DATA(^TMP("AMER",$JOB,2,34))
SET %=+^(34)
IF %>0
SET DIC("B")=$PIECE(^AMER(3,%,0),U)
+3 SET DIC="^AMER(3,"
SET DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("SCENE OF INJURY")
SET DIC(0)="AEQ"
+4 DO ^DIC
KILL DIC
SET Y=+Y
+5 ;
+6 ;AMER*3.0*6;Added call to update BEDD
+7 NEW INJ
+8 ;AMER*3.0*7;Added in DO
+9 ;I +Y>0 S INJ=Y
+10 IF +Y>0
SET INJ=Y
Begin DoDot:1
+11 NEW Y
+12 DO INJ^AMERBEDD("INJ.PtInjury.InjSet",INJ)
End DoDot:1
+13 KILL INJ
+14 ;
+15 DO OUT^AMER
+16 ;
+17 ;No longer in use
+18 ;S Z=U,%="MOTOR VEHICLE^BICYCLE^TOOLS JOB EQUIP.^INHILATION (GAS/SMOKE)^CHEMICALS (CAUSTIC OR TOXIC)^ELECTRICITY^FIRE FLAME^FALL (ACCIDENTAL)" F I=1:1:$L(%,U) S A=$P(%,U,I),Z=Z_+$O(^AMER(3,"B",A,0))_U
+19 ;S %=$P($G(^TMP("AMER",$J,2,33)),U) I Z'[(U_%_U) G QD35A ; SAFETY EQUIP NOT RELEVANT
+20 QUIT
+21 ;
QD35 ; SAFETY EQUIPMENT OF INJURY
+1 NEW A,Z,%
+2 SET DIC("A")="Safety equipment used: "
KILL DIC("B")
+3 IF $DATA(^TMP("AMER",$JOB,2,35))
SET %=+^(35)
IF %>0
SET DIC("B")=$PIECE(^AMER(3,%,0),U)
+4 SET DIC="^AMER(3,"
SET DIC("S")="I $P(^(0),U,2)="_$$CAT^AMER0("SAFETY EQUIPMENT")
SET DIC(0)="AEQ"
+5 DO ^DIC
KILL DIC
SET Y=+Y
+6 ;
+7 ;AMER*3.0*6;Added call to update BEDD
+8 NEW INJ
+9 ;AMER*3.0*7;Added in DO
+10 ;I +Y>0 S INJ=Y
+11 IF +Y>0
SET INJ=Y
Begin DoDot:1
+12 NEW Y
+13 DO INJ^AMERBEDD("INJ.PtInjury.SafetyEquip",INJ)
End DoDot:1
+14 KILL INJ
+15 ;
+16 DO OUT^AMER
IF $DATA(AMERQUIT)
QUIT
QD35A ;
+1 ;
+2 NEW MVA
+3 ;
+4 SET MVA=""
+5 ;
+6 ;Look for MVA
+7 IF $GET(AMERDFN)]""
Begin DoDot:1
+8 NEW DESC,%,I
+9 SET %=$PIECE($GET(^TMP("AMER",$JOB,2,33)),U)
+10 SET DESC=$$DESC(%,AMERDFN,"","")
+11 FOR I="MOTOR","VEH","MV","TRAFFIC"
IF $$UP^XLFSTR(DESC)[I
SET MVA=1
End DoDot:1
+12 ;
+13 ;If MVA ask additional questions
+14 ; MVA
IF MVA=1
Begin DoDot:1
+15 SET AMERRUN=40
+16 ; MVA
FOR I=61:1:64
KILL ^TMP("AMER",$JOB,2,I)
+17 QUIT
End DoDot:1
QUIT
+18 ;
+19 ;Not a MVA
+20 FOR I=41:1:46,51:1:57,61:1:64
KILL ^TMP("AMER",$JOB,2,I)
+21 IF $DATA(AMEREFLG)
SET AMERRUN=99
+22 IF '$TEST
SET AMERRUN=4
+23 QUIT
+24 ;
QD41 ; DESCIPTION OF MVA LOCATION
+1 KILL DIR("B")
IF $DATA(^TMP("AMER",$JOB,2,41))
SET DIR("B")=^(41)
+2 SET DIR(0)="FO^1:100"
SET DIR("A")="Location of MVC (if applicable)"
SET DIR("?")="Enter free text location description (100 characters max.)"
DO ^DIR
KILL DIR
+3 DO CKSC^AMER1
IF $DATA(AMERCKSC)
KILL AMERCKSC
GOTO QD41
+4 DO OUT^AMER
IF $DATA(AMERQUIT)
QUIT
+5 SET AMERRUN=4
+6 QUIT
+7 ;
CKANS() ;EP - Check answer "^", "^^", and timeout
+1 ;
+2 ;User typed "^^"
+3 IF $GET(DIROUT)
QUIT 3
+4 ;
+5 ;User typed "^" or timed out
+6 IF $GET(DUOUT)!$GET(DTOUT)
QUIT 2
+7 ;
+8 ;User hit ENTER
+9 IF $GET(DIRUT)
QUIT 1
+10 ;
+11 QUIT 0
+12 ;
DESC(X,D0,CODE,VDATE) ;Return the ICD Description
+1 ;
+2 NEW ICDDESC
+3 ;
+4 ;Make the call to get the string
+5 SET ICDDESC=$$DX^AMERPOV($GET(X),$GET(D0),$GET(CODE),$GET(VDATE))
+6 QUIT ICDDESC
