- 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
