APCDFHS ;IHS/CMI/LAB - LIST MANAGER SNOMED SELECTION FOR FAMILY HISTORY AND API FOR REP FACTORS
;;2.0;IHS PCC SUITE;**10,11,13,16**;MAY 14, 2009;Build 9
;; ;
EN ;EP -- main entry point for
NEW APCDFHSN,APCDHIGH,APCDTCI,APCDTDI,I
D EN^VALM("APCD FH SNOMED VIEW")
D CLEAR^VALM1
D FULL^VALM1
W:$D(IOF) @IOF
D EOJ
Q
EOJ ;
K ^TMP($J,"APCDFHSNOMED"),APCDFHSN
Q
;
HDR ; -- header code
S VALMHDR(1)="SELECT FAMILY HISTORY SNOMED TERM"
Q
;
INIT ;EP --
NEW OUT,IN,C,J,Y,X,I
K ^TMP($J,"APCDFHSNOMED")
S OUT=$NA(^TMP($J,"APCDFHSNOMED")),IN="SRCH Family History"
S X=$$SUBLST^BSTSAPI(OUT,IN)
S APCDHIGH="",C=0,J=0
F S J=$O(^TMP($J,"APCDFHSNOMED",J)) Q:J="" D
.S Y=^TMP($J,"APCDFHSNOMED",J)
.S C=C+1 ;counter
.S APCDTCI=$P(Y,U,1),APCDTDI=$P(Y,U,2),APCDTPT=$P(Y,U,3)
.S I=$P($P($$CONC^AUPNSICD(APCDTCI_"^^"_$S($G(APCDDATE):APCDDATE,1:DT)_"^1"),U,5),";")
.S X=""
.S X=C_") ",$E(X,7)=APCDTCI,$E(X,23)=APCDTPT_" ("_I_")"
.S APCDFHSN(C,0)=X
.S APCDFHSN("IDX",C,C)=J_U_APCDTCI_U_APCDTDI
.Q
S (VALMCNT,APCDHIGH)=C
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
;
BACK ;go back to listman
D TERM^VALM0
S VALMBCK="R"
D INIT
D HDR
K DIR
K X,Y,Z,I
Q
;
SELECT ;EP - add an item to the selected list - called from a protocol
W !
S DIR(0)="NO^1:"_APCDHIGH,DIR("A")="Which SNOMED Term"
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !,"No SNOMED selected." G DISPX
I $D(DIRUT) W !,"No SNOMED selected." G DISPX
S APCDCI=$P(APCDFHSN("IDX",Y,Y),U,2)
S APCDDI=$P(APCDFHSN("IDX",Y,Y),U,3)
;W !!,$$CONC^AUPNSICD(APCDCI_"^^"_$S($G(APCDDATE):APCDDATE,1:DT)_"^1") H 10
S APCDICD=$P($P($$CONC^AUPNSICD(APCDCI_"^^"_$S($G(APCDDATE):APCDDATE,1:DT)_"^1"),U,5),";")
K ^TMP($J,"APCDFHSNOMED"),APCDFHSN
Q
;
DISPX ;
D BACK
Q
GETNARR(APCDDEFV) ;EP - called to get a narrative
;because I have absolutely no idea where this call is coming from
;I am going to do an exclusive new to preserve the callers
;symbol table
NEW APCDNQV
S APCDNQV=""
S APCDDEFV=$G(APCDDEFV)
D EN^XBNEW("GETNARR1^APCDFHS","APCDNQV;APCDDEFV")
Q APCDNQV
GETNARR1 ;EP
;if user enters "=" use T IF T is not null
;do not allow "|"
;do not allow "@"
NEW DA,DIR
S T=$G(T)
S DIR(0)="FO^1:160",DIR("A")="PROVIDER NARRATIVE" S:APCDDEFV]"" DIR("B")=APCDDEFV KILL DA D ^DIR KILL DIR
;I $D(DIRUT),X="^" W !!," ^ is Not Allowed. Response is required.",! G GETNARR1
I $D(DIRUT) Q ""
I X="" Q ""
I $L(X)>160!($L(X)<2)!'((X'?1P.E)!(X?1"|".E))!(X'?.ANP) W " ????" G GETNARR1
I X["|" W !!,"You cannot enter a narrative that contains a '|' (vertical bar).",! K X G GETNARR1
S APCDNQV=X
Q
APCDFHS ;IHS/CMI/LAB - LIST MANAGER SNOMED SELECTION FOR FAMILY HISTORY AND API FOR REP FACTORS
+1 ;;2.0;IHS PCC SUITE;**10,11,13,16**;MAY 14, 2009;Build 9
+2 ;; ;
EN ;EP -- main entry point for
+1 NEW APCDFHSN,APCDHIGH,APCDTCI,APCDTDI,I
+2 DO EN^VALM("APCD FH SNOMED VIEW")
+3 DO CLEAR^VALM1
+4 DO FULL^VALM1
+5 IF $DATA(IOF)
WRITE @IOF
+6 DO EOJ
+7 QUIT
EOJ ;
+1 KILL ^TMP($JOB,"APCDFHSNOMED"),APCDFHSN
+2 QUIT
+3 ;
HDR ; -- header code
+1 SET VALMHDR(1)="SELECT FAMILY HISTORY SNOMED TERM"
+2 QUIT
+3 ;
INIT ;EP --
+1 NEW OUT,IN,C,J,Y,X,I
+2 KILL ^TMP($JOB,"APCDFHSNOMED")
+3 SET OUT=$NAME(^TMP($JOB,"APCDFHSNOMED"))
SET IN="SRCH Family History"
+4 SET X=$$SUBLST^BSTSAPI(OUT,IN)
+5 SET APCDHIGH=""
SET C=0
SET J=0
+6 FOR
SET J=$ORDER(^TMP($JOB,"APCDFHSNOMED",J))
IF J=""
QUIT
Begin DoDot:1
+7 SET Y=^TMP($JOB,"APCDFHSNOMED",J)
+8 ;counter
SET C=C+1
+9 SET APCDTCI=$PIECE(Y,U,1)
SET APCDTDI=$PIECE(Y,U,2)
SET APCDTPT=$PIECE(Y,U,3)
+10 SET I=$PIECE($PIECE($$CONC^AUPNSICD(APCDTCI_"^^"_$SELECT($GET(APCDDATE):APCDDATE,1:DT)_"^1"),U,5),";")
+11 SET X=""
+12 SET X=C_") "
SET $EXTRACT(X,7)=APCDTCI
SET $EXTRACT(X,23)=APCDTPT_" ("_I_")"
+13 SET APCDFHSN(C,0)=X
+14 SET APCDFHSN("IDX",C,C)=J_U_APCDTCI_U_APCDTDI
+15 QUIT
End DoDot:1
+16 SET (VALMCNT,APCDHIGH)=C
+17 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
BACK ;go back to listman
+1 DO TERM^VALM0
+2 SET VALMBCK="R"
+3 DO INIT
+4 DO HDR
+5 KILL DIR
+6 KILL X,Y,Z,I
+7 QUIT
+8 ;
SELECT ;EP - add an item to the selected list - called from a protocol
+1 WRITE !
+2 SET DIR(0)="NO^1:"_APCDHIGH
SET DIR("A")="Which SNOMED Term"
+3 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF Y=""
WRITE !,"No SNOMED selected."
GOTO DISPX
+5 IF $DATA(DIRUT)
WRITE !,"No SNOMED selected."
GOTO DISPX
+6 SET APCDCI=$PIECE(APCDFHSN("IDX",Y,Y),U,2)
+7 SET APCDDI=$PIECE(APCDFHSN("IDX",Y,Y),U,3)
+8 ;W !!,$$CONC^AUPNSICD(APCDCI_"^^"_$S($G(APCDDATE):APCDDATE,1:DT)_"^1") H 10
+9 SET APCDICD=$PIECE($PIECE($$CONC^AUPNSICD(APCDCI_"^^"_$SELECT($GET(APCDDATE):APCDDATE,1:DT)_"^1"),U,5),";")
+10 KILL ^TMP($JOB,"APCDFHSNOMED"),APCDFHSN
+11 QUIT
+12 ;
DISPX ;
+1 DO BACK
+2 QUIT
GETNARR(APCDDEFV) ;EP - called to get a narrative
+1 ;because I have absolutely no idea where this call is coming from
+2 ;I am going to do an exclusive new to preserve the callers
+3 ;symbol table
+4 NEW APCDNQV
+5 SET APCDNQV=""
+6 SET APCDDEFV=$GET(APCDDEFV)
+7 DO EN^XBNEW("GETNARR1^APCDFHS","APCDNQV;APCDDEFV")
+8 QUIT APCDNQV
GETNARR1 ;EP
+1 ;if user enters "=" use T IF T is not null
+2 ;do not allow "|"
+3 ;do not allow "@"
+4 NEW DA,DIR
+5 SET T=$GET(T)
+6 SET DIR(0)="FO^1:160"
SET DIR("A")="PROVIDER NARRATIVE"
IF APCDDEFV]""
SET DIR("B")=APCDDEFV
KILL DA
DO ^DIR
KILL DIR
+7 ;I $D(DIRUT),X="^" W !!," ^ is Not Allowed. Response is required.",! G GETNARR1
+8 IF $DATA(DIRUT)
QUIT ""
+9 IF X=""
QUIT ""
+10 IF $LENGTH(X)>160!($LENGTH(X)<2)!'((X'?1P.E)!(X?1"|".E))!(X'?.ANP)
WRITE " ????"
GOTO GETNARR1
+11 IF X["|"
WRITE !!,"You cannot enter a narrative that contains a '|' (vertical bar).",!
KILL X
GOTO GETNARR1
+12 SET APCDNQV=X
+13 QUIT
