- APCLTAXE ; IHS/CMI/LAB - DISPLAY IND LISTS ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;; ;
- EP ;EP - CALLED FROM OPTION
- D EN
- Q
- EOJ ;EP
- D ^XBFMK
- K APCLITEM,APCLX,APCLTAXI,APCLITMI,APCLHIGH,APCLTXLI
- Q
- ;; ;
- EN ;EP -- main entry point for
- D EN^VALM("APCL TAXONOMY GENERIC EDIT")
- D CLEAR^VALM1
- D FULL^VALM1
- W:$D(IOF) @IOF
- D EOJ
- Q
- ;
- PAUSE ;EP
- Q:$E(IOST)'="C"!(IO'=IO(0))
- W ! S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
- Q
- HDR ; -- header code
- S VALMHDR(1)="Updating the "_APCLTAXN_" taxonomy"
- Q
- ;
- INIT ; -- init variables and list array
- I APCLFILE=60 D LAB Q
- I $P(^ATXAX(APCLTAXI,0),U,13) D CANDISP Q
- K APCLITEM S APCLHIGH="",C=0
- S APCLX=0 F S APCLX=$O(^ATXAX(APCLTAXI,21,APCLX)) Q:APCLX'=+APCLX D
- .S C=C+1
- .S APCLITMI=$P(^ATXAX(APCLTAXI,21,APCLX,0),U)
- .I APCLFILE=9999999.05 S APCLITEM(C,0)=C_") "_APCLITMI I 1
- .E S APCLITEM(C,0)=C_") "_$$VAL^XBDIQ1($P(^ATXAX(APCLTAXI,0),U,15),APCLITMI,.01)
- .S APCLITEM("IDX",C,C)=APCLITMI
- .Q
- S (VALMCNT,APCLHIGH)=C
- Q
- CANDISP ;
- K APCLITEM S APCLHIGH="",C=0
- S APCLX=0 F S APCLX=$O(^ATXAX(APCLTAXI,21,APCLX)) Q:APCLX'=+APCLX D
- .S C=C+1
- .S APCLITEM(C,0)=C_") "_$P(^ATXAX(APCLTAXI,21,APCLX,0),U)_"-"_$P(^ATXAX(APCLTAXI,21,APCLX,0),U,2)
- .S APCLITEM("IDX",C,C)=APCLX
- .Q
- S (VALMCNT,APCLHIGH)=C
- Q
- LAB ;
- K APCLITEM S APCLHIGH="",C=0
- S APCLX=0 F S APCLX=$O(^ATXLAB(APCLTAXI,21,APCLX)) Q:APCLX'=+APCLX D
- .S C=C+1
- .S APCLITMI=$P(^ATXLAB(APCLTAXI,21,APCLX,0),U)
- .S APCLITEM(C,0)=C_") "_$P($G(^LAB(60,APCLITMI,0)),U)
- .S APCLITEM("IDX",C,C)=APCLITMI
- .Q
- S (VALMCNT,APCLHIGH)=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
- ;
- REM ;
- D FULL^VALM1
- W !
- I APCLFILE=60,$P(^ATXLAB(APCLTAXI,0),U,22) W !!,"The ",$P(^ATXLAB(APCLTAXI,0),U)," Taxonomy is READ ONLY.",!,"You can not update it." D PAUSE G REMX
- I APCLFILE'=60,$P(^ATXAX(APCLTAXI,0),U,22) W !!,"The ",$P(^ATXAX(APCLTAXI,0),U)," Taxonomy is READ ONLY.",!,"You can not update it." D PAUSE G REMX
- W ! K DIR
- I APCLFILE=80 D ICD9ADD G REMX
- I APCLFILE=80.1 D ICD0ADD G REMX
- I APCLFILE=81 D ICPTADD G REMX
- ;I APCLFILE'=60,$P(^ATXTYPE(APCLTAXT,0),U,4)=1 D ICD9ADD G REMX
- S DIR(0)="NO^1:"_APCLHIGH,DIR("A")="Remove Which Item"
- D ^DIR K DIR S:$D(DUOUT) DIRUT=1
- I Y="" W !,"No item selected." G REMX
- I $D(DIRUT) W !,"No item selected." G REMX
- S APCLITMI=APCLITEM("IDX",Y,Y)
- ;sure
- I APCLFILE=60 K DIR S DIR(0)="Y",DIR("A")="Are you sure you want to remove the "_$P(^LAB(60,APCLITMI,0),U)_" lab test",DIR("B")="N" KILL DA D ^DIR KILL DIR
- I APCLFILE'=60,APCLTAXT K DIR D
- .S DIR(0)="Y",DIR("A")="Are you sure you want to remove the "_$S(APCLFILE'=9999999.05:$$VAL^XBDIQ1($P(^ATXAX(APCLTAXI,0),U,15),APCLITMI,.01),1:APCLITMI)_" "_$$VAL^XBDIQ1(9002226,APCLTAXI,.15),DIR("B")="N" KILL DA D ^DIR KILL DIR
- I 'Y G REM
- I $D(DIRUT) G REMX
- D ^XBFMK
- I APCLFILE=60 S DA(1)=APCLTAXI,DA=$O(^ATXLAB(APCLTAXI,21,"B",APCLITMI,0)),DIE="^ATXLAB("_APCLTAXI_",21,",DR=".01///@" D ^DIE
- I APCLFILE'=60 S DA(1)=APCLTAXI,DA=$O(^ATXAX(APCLTAXI,21,"B",APCLITMI,0)),DIE="^ATXAX("_APCLTAXI_",21,",DR=".01///@" D ^DIE
- REMX ;
- D ^XBFMK
- D BACK
- Q
- ADD ;EP - add an item to the selected list - called from a protocol
- D FULL^VALM1
- W !
- I APCLFILE=60,$P(^ATXLAB(APCLTAXI,0),U,22) W !!,"The ",$P(^ATXLAB(APCLTAXI,0),U)," is READ ONLY.",!,"You can not update it." D PAUSE G ADDX
- I APCLFILE'=60,$P(^ATXAX(APCLTAXI,0),U,22) W !!,"The ",$P(^ATXAX(APCLTAXI,0),U)," is READ ONLY.",!,"You can not update it." D PAUSE G ADDX
- I APCLFILE=60 D LABADD G ADDX
- I APCLFILE=80 D ICD9ADD G ADDX
- I APCLFILE=80.1 D ICD0ADD G ADDX
- I APCLFILE=81 D ICPTADD G ADDX
- K DIC
- S DIC(0)="AEMQ",DIC=$P(^ATXAX(APCLTAXI,0),U,15) D ^DIC
- I Y=-1 G ADDX
- I $D(^ATXAX(APCLTAXI,21,"B",$S(APCLFILE'=9999999.05:+Y,1:$P(^AUTTCOM(+Y,0),U,1)))) W !!,"That item is already in the taxonomy." H 2 G ADD
- S DA=APCLTAXI
- S (X,APCLTXLI)=+Y
- I APCLFILE=9999999.05 S (X,APCLTXLI)=$P(^AUTTCOM(+Y,0),U) ;special processing for community
- S APCLFILE=$P(^ATXAX(APCLTAXI,0),U,15)
- S DA(1)=APCLTAXI
- S DIC="^ATXAX("_DA_",21,"
- S DIC(0)="L",DIC("DR")=".02////"_APCLTXLI K DD,DO
- S:'$D(^ATXAX(DA,21,0)) ^ATXAX(DA,21,0)="^9002226.02101A"
- D FILE^DICN
- I '$D(^ATXAX(APCLTAXI,21,"B",APCLTXLI)) W !!,"adding ITEM failed." H 2 G ADD
- G ADDX
- LABADD ;
- K DIC
- S DIC(0)="AEMQ",DIC="^LAB(60,",DIC("A")="Which LAB Test: " D ^DIC
- I Y=-1 G ADDX
- S APCLTXLI=+Y
- I '$P(^ATXLAB(APCLTAXI,0),U,11),$O(^LAB(60,APCLTXLI,2,0)) S APCLYN="" D G:'APCLYN ADDX
- .W !!,"This lab test, ",$P(^LAB(60,APCLTXLI,0),U),", is a panel test and the"
- .W !,"taxonomy ",$P(^ATXLAB(APCLTAXI,0),U)," should not contain panel tests.",!
- .S DIR(0)="Y",DIR("A")="Do you still want to add this lab test to this taxonomy",DIR("B")="N" KILL DA D ^DIR KILL DIR
- .Q:$D(DIRUT)
- .S APCLYN=Y
- I $D(^ATXLAB(APCLTAXI,21,"B",APCLTXLI)) W !!,"Lab test ",$P(^LAB(60,APCLTXLI,0),U)," is already in the taxonomy." H 2 G ADD
- S DA=APCLTAXI
- S X=APCLTXLI
- S DA(1)=APCLTAXI
- S DIC="^ATXLAB("_DA_",21,"
- S DIC(0)="L" K DD,DO
- S:'$D(^ATXLAB(DA,21,0)) ^ATXLAB(DA,21,0)="^9002228.02101PA"
- D FILE^DICN
- I '$D(^ATXLAB(APCLTAXI,21,"B",APCLTXLI)) W !!,"adding lab test failed." H 2 G ADD
- ADDX ;
- K DIC,DA,DR,APCLTXLI,DD,DO
- D BACK
- Q
- ICD9ADD ;
- D ICD9ADD^APCLTAXF
- Q
- ICD0ADD ;
- D ICD0ADD^APCLTAXH
- Q
- ICPTADD ;
- D ICPTADD^APCLTAXL
- Q
- APCLTAXE ; IHS/CMI/LAB - DISPLAY IND LISTS ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;; ;
- EP ;EP - CALLED FROM OPTION
- +1 DO EN
- +2 QUIT
- EOJ ;EP
- +1 DO ^XBFMK
- +2 KILL APCLITEM,APCLX,APCLTAXI,APCLITMI,APCLHIGH,APCLTXLI
- +3 QUIT
- +4 ;; ;
- EN ;EP -- main entry point for
- +1 DO EN^VALM("APCL TAXONOMY GENERIC EDIT")
- +2 DO CLEAR^VALM1
- +3 DO FULL^VALM1
- +4 IF $DATA(IOF)
- WRITE @IOF
- +5 DO EOJ
- +6 QUIT
- +7 ;
- PAUSE ;EP
- +1 IF $EXTRACT(IOST)'="C"!(IO'=IO(0))
- QUIT
- +2 WRITE !
- SET DIR(0)="EO"
- SET DIR("A")="Press enter to continue...."
- DO ^DIR
- KILL DIR
- IF $DATA(DUOUT)
- SET DIRUT=1
- +3 QUIT
- HDR ; -- header code
- +1 SET VALMHDR(1)="Updating the "_APCLTAXN_" taxonomy"
- +2 QUIT
- +3 ;
- INIT ; -- init variables and list array
- +1 IF APCLFILE=60
- DO LAB
- QUIT
- +2 IF $PIECE(^ATXAX(APCLTAXI,0),U,13)
- DO CANDISP
- QUIT
- +3 KILL APCLITEM
- SET APCLHIGH=""
- SET C=0
- +4 SET APCLX=0
- FOR
- SET APCLX=$ORDER(^ATXAX(APCLTAXI,21,APCLX))
- IF APCLX'=+APCLX
- QUIT
- Begin DoDot:1
- +5 SET C=C+1
- +6 SET APCLITMI=$PIECE(^ATXAX(APCLTAXI,21,APCLX,0),U)
- +7 IF APCLFILE=9999999.05
- SET APCLITEM(C,0)=C_") "_APCLITMI
- IF 1
- +8 IF '$TEST
- SET APCLITEM(C,0)=C_") "_$$VAL^XBDIQ1($PIECE(^ATXAX(APCLTAXI,0),U,15),APCLITMI,.01)
- +9 SET APCLITEM("IDX",C,C)=APCLITMI
- +10 QUIT
- End DoDot:1
- +11 SET (VALMCNT,APCLHIGH)=C
- +12 QUIT
- CANDISP ;
- +1 KILL APCLITEM
- SET APCLHIGH=""
- SET C=0
- +2 SET APCLX=0
- FOR
- SET APCLX=$ORDER(^ATXAX(APCLTAXI,21,APCLX))
- IF APCLX'=+APCLX
- QUIT
- Begin DoDot:1
- +3 SET C=C+1
- +4 SET APCLITEM(C,0)=C_") "_$PIECE(^ATXAX(APCLTAXI,21,APCLX,0),U)_"-"_$PIECE(^ATXAX(APCLTAXI,21,APCLX,0),U,2)
- +5 SET APCLITEM("IDX",C,C)=APCLX
- +6 QUIT
- End DoDot:1
- +7 SET (VALMCNT,APCLHIGH)=C
- +8 QUIT
- LAB ;
- +1 KILL APCLITEM
- SET APCLHIGH=""
- SET C=0
- +2 SET APCLX=0
- FOR
- SET APCLX=$ORDER(^ATXLAB(APCLTAXI,21,APCLX))
- IF APCLX'=+APCLX
- QUIT
- Begin DoDot:1
- +3 SET C=C+1
- +4 SET APCLITMI=$PIECE(^ATXLAB(APCLTAXI,21,APCLX,0),U)
- +5 SET APCLITEM(C,0)=C_") "_$PIECE($GET(^LAB(60,APCLITMI,0)),U)
- +6 SET APCLITEM("IDX",C,C)=APCLITMI
- +7 QUIT
- End DoDot:1
- +8 SET (VALMCNT,APCLHIGH)=C
- +9 QUIT
- +10 ;
- 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 ;
- REM ;
- +1 DO FULL^VALM1
- +2 WRITE !
- +3 IF APCLFILE=60
- IF $PIECE(^ATXLAB(APCLTAXI,0),U,22)
- WRITE !!,"The ",$PIECE(^ATXLAB(APCLTAXI,0),U)," Taxonomy is READ ONLY.",!,"You can not update it."
- DO PAUSE
- GOTO REMX
- +4 IF APCLFILE'=60
- IF $PIECE(^ATXAX(APCLTAXI,0),U,22)
- WRITE !!,"The ",$PIECE(^ATXAX(APCLTAXI,0),U)," Taxonomy is READ ONLY.",!,"You can not update it."
- DO PAUSE
- GOTO REMX
- +5 WRITE !
- KILL DIR
- +6 IF APCLFILE=80
- DO ICD9ADD
- GOTO REMX
- +7 IF APCLFILE=80.1
- DO ICD0ADD
- GOTO REMX
- +8 IF APCLFILE=81
- DO ICPTADD
- GOTO REMX
- +9 ;I APCLFILE'=60,$P(^ATXTYPE(APCLTAXT,0),U,4)=1 D ICD9ADD G REMX
- +10 SET DIR(0)="NO^1:"_APCLHIGH
- SET DIR("A")="Remove Which Item"
- +11 DO ^DIR
- KILL DIR
- IF $DATA(DUOUT)
- SET DIRUT=1
- +12 IF Y=""
- WRITE !,"No item selected."
- GOTO REMX
- +13 IF $DATA(DIRUT)
- WRITE !,"No item selected."
- GOTO REMX
- +14 SET APCLITMI=APCLITEM("IDX",Y,Y)
- +15 ;sure
- +16 IF APCLFILE=60
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Are you sure you want to remove the "_$PIECE(^LAB(60,APCLITMI,0),U)_" lab test"
- SET DIR("B")="N"
- KILL DA
- DO ^DIR
- KILL DIR
- +17 IF APCLFILE'=60
- IF APCLTAXT
- KILL DIR
- Begin DoDot:1
- +18 SET DIR(0)="Y"
- SET DIR("A")="Are you sure you want to remove the "_$SELECT(APCLFILE'=9999999.05:$$VAL^XBDIQ1($PIECE(^ATXAX(APCLTAXI,0),U,15),APCLITMI,.01),1:APCLITMI)_" "_$$VAL^XBDIQ1(9002226,APCLTAXI,.15)
- SET DIR("B")="N"
- KILL DA
- DO ^DIR
- KILL DIR
- End DoDot:1
- +19 IF 'Y
- GOTO REM
- +20 IF $DATA(DIRUT)
- GOTO REMX
- +21 DO ^XBFMK
- +22 IF APCLFILE=60
- SET DA(1)=APCLTAXI
- SET DA=$ORDER(^ATXLAB(APCLTAXI,21,"B",APCLITMI,0))
- SET DIE="^ATXLAB("_APCLTAXI_",21,"
- SET DR=".01///@"
- DO ^DIE
- +23 IF APCLFILE'=60
- SET DA(1)=APCLTAXI
- SET DA=$ORDER(^ATXAX(APCLTAXI,21,"B",APCLITMI,0))
- SET DIE="^ATXAX("_APCLTAXI_",21,"
- SET DR=".01///@"
- DO ^DIE
- REMX ;
- +1 DO ^XBFMK
- +2 DO BACK
- +3 QUIT
- ADD ;EP - add an item to the selected list - called from a protocol
- +1 DO FULL^VALM1
- +2 WRITE !
- +3 IF APCLFILE=60
- IF $PIECE(^ATXLAB(APCLTAXI,0),U,22)
- WRITE !!,"The ",$PIECE(^ATXLAB(APCLTAXI,0),U)," is READ ONLY.",!,"You can not update it."
- DO PAUSE
- GOTO ADDX
- +4 IF APCLFILE'=60
- IF $PIECE(^ATXAX(APCLTAXI,0),U,22)
- WRITE !!,"The ",$PIECE(^ATXAX(APCLTAXI,0),U)," is READ ONLY.",!,"You can not update it."
- DO PAUSE
- GOTO ADDX
- +5 IF APCLFILE=60
- DO LABADD
- GOTO ADDX
- +6 IF APCLFILE=80
- DO ICD9ADD
- GOTO ADDX
- +7 IF APCLFILE=80.1
- DO ICD0ADD
- GOTO ADDX
- +8 IF APCLFILE=81
- DO ICPTADD
- GOTO ADDX
- +9 KILL DIC
- +10 SET DIC(0)="AEMQ"
- SET DIC=$PIECE(^ATXAX(APCLTAXI,0),U,15)
- DO ^DIC
- +11 IF Y=-1
- GOTO ADDX
- +12 IF $DATA(^ATXAX(APCLTAXI,21,"B",$SELECT(APCLFILE'=9999999.05:+Y,1:$PIECE(^AUTTCOM(+Y,0),U,1))))
- WRITE !!,"That item is already in the taxonomy."
- HANG 2
- GOTO ADD
- +13 SET DA=APCLTAXI
- +14 SET (X,APCLTXLI)=+Y
- +15 ;special processing for community
- IF APCLFILE=9999999.05
- SET (X,APCLTXLI)=$PIECE(^AUTTCOM(+Y,0),U)
- +16 SET APCLFILE=$PIECE(^ATXAX(APCLTAXI,0),U,15)
- +17 SET DA(1)=APCLTAXI
- +18 SET DIC="^ATXAX("_DA_",21,"
- +19 SET DIC(0)="L"
- SET DIC("DR")=".02////"_APCLTXLI
- KILL DD,DO
- +20 IF '$DATA(^ATXAX(DA,21,0))
- SET ^ATXAX(DA,21,0)="^9002226.02101A"
- +21 DO FILE^DICN
- +22 IF '$DATA(^ATXAX(APCLTAXI,21,"B",APCLTXLI))
- WRITE !!,"adding ITEM failed."
- HANG 2
- GOTO ADD
- +23 GOTO ADDX
- LABADD ;
- +1 KILL DIC
- +2 SET DIC(0)="AEMQ"
- SET DIC="^LAB(60,"
- SET DIC("A")="Which LAB Test: "
- DO ^DIC
- +3 IF Y=-1
- GOTO ADDX
- +4 SET APCLTXLI=+Y
- +5 IF '$PIECE(^ATXLAB(APCLTAXI,0),U,11)
- IF $ORDER(^LAB(60,APCLTXLI,2,0))
- SET APCLYN=""
- Begin DoDot:1
- +6 WRITE !!,"This lab test, ",$PIECE(^LAB(60,APCLTXLI,0),U),", is a panel test and the"
- +7 WRITE !,"taxonomy ",$PIECE(^ATXLAB(APCLTAXI,0),U)," should not contain panel tests.",!
- +8 SET DIR(0)="Y"
- SET DIR("A")="Do you still want to add this lab test to this taxonomy"
- SET DIR("B")="N"
- KILL DA
- DO ^DIR
- KILL DIR
- +9 IF $DATA(DIRUT)
- QUIT
- +10 SET APCLYN=Y
- End DoDot:1
- IF 'APCLYN
- GOTO ADDX
- +11 IF $DATA(^ATXLAB(APCLTAXI,21,"B",APCLTXLI))
- WRITE !!,"Lab test ",$PIECE(^LAB(60,APCLTXLI,0),U)," is already in the taxonomy."
- HANG 2
- GOTO ADD
- +12 SET DA=APCLTAXI
- +13 SET X=APCLTXLI
- +14 SET DA(1)=APCLTAXI
- +15 SET DIC="^ATXLAB("_DA_",21,"
- +16 SET DIC(0)="L"
- KILL DD,DO
- +17 IF '$DATA(^ATXLAB(DA,21,0))
- SET ^ATXLAB(DA,21,0)="^9002228.02101PA"
- +18 DO FILE^DICN
- +19 IF '$DATA(^ATXLAB(APCLTAXI,21,"B",APCLTXLI))
- WRITE !!,"adding lab test failed."
- HANG 2
- GOTO ADD
- ADDX ;
- +1 KILL DIC,DA,DR,APCLTXLI,DD,DO
- +2 DO BACK
- +3 QUIT
- ICD9ADD ;
- +1 DO ICD9ADD^APCLTAXF
- +2 QUIT
- ICD0ADD ;
- +1 DO ICD0ADD^APCLTAXH
- +2 QUIT
- ICPTADD ;
- +1 DO ICPTADD^APCLTAXL
- +2 QUIT
