- BLSELL ; IHS/CMI/LAB - UPDATE TESTS TO EXPORT ; [ 12/19/2002 7:26 AM ]
- ;;5.2;LR;**1015**;NOV 18, 2002
- ;; ;
- EN ;EP -- main entry point for BLS LOINC TO EXPORT
- D EN^VALM("BLS LOINC TO EXPORT")
- D CLEAR^VALM1
- D FULL^VALM1
- D EXIT
- Q
- ;
- HDR ; -- header code
- S VALMHDR(1)="List of Lab Tests (by LOINC Code) that are currently being"
- S VALMHDR(2)="exported to CDC."
- S VALMHDR(3)="You may add a new code to the list or remove an existing code from the list."
- Q
- ;
- INIT ; -- init variables and list array
- K BLSELL S BLSC=0,BLSX=0
- F S BLSX=$O(^BLSELL(BLSX)) Q:BLSX'=+BLSX D
- .S BLSC=BLSC+1,BLSELL("IDX",BLSC,BLSC)=BLSX
- .S BLSIEN=$P(^BLSELL(BLSX,0),U),BLSELL(BLSC,0)=BLSC_")",$E(BLSELL(BLSC,0),6)=$P(^LAB(95.3,BLSIEN,0),U),$E(BLSELL(BLSC,0),13)=$P($G(^LAB(95.3,BLSIEN,80)),U)
- S VALMCNT=BLSC
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- D EN^XBVK("BLS")
- D ^XBFMK
- Q
- ;
- EXPND ; -- expand code
- Q
- ;
- EOP ;EP - End of page.
- Q:$E(IOST)'="C"
- Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
- NEW DIR
- K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
- S DIR(0)="E" D ^DIR
- Q
- ;----------
- BACK ;go back to listman
- D TERM^VALM0
- S VALMBCK="R"
- D INIT
- D HDR
- K DIR
- K X,Y,Z,I D ^XBFMK
- Q
- ;
- ADD ;EP - add an item to the selected list - called from a protocol
- D FULL^VALM1
- W !,"Adding new Lab Test (LOINC code) to the exported lab test list....",!
- D ^XBFMK
- S DIC="^BLSELL(",DIC(0)="AEMQL" D ^DIC
- D BACK
- Q
- ;
- REM ;
- D FULL^VALM1
- NEW LIEN
- S LIEN=0
- D EN^VALM2(XQORNOD(0),"OS") ;this list man call allows user to select an entry in list
- I '$D(VALMY) W !,"No Loinc Code selected." G REMX
- S LIEN=$O(VALMY(0)) I 'LIEN K LIEN,VALMY,XQORNOD W !,"No Loinc Code selected." G REMX
- S LIEN=BLSELL("IDX",LIEN,LIEN)
- I '$D(^BLSELL(LIEN,0)) W !,"Not a valid LOINC ENTRY." K LIEN S LIEN=0 G REMX
- W !!,"Deleting LOINC code "_$P(^LAB(95.3,$P(^BLSELL(LIEN,0),U),0),U)_" from list of exported Lab Tests.",!
- S DA=LIEN,DIK="^BLSELL(" D ^DIK
- K DIK
- REMX ;
- D EOP
- K DIR
- K LIEN
- D BACK
- Q
- ;
- BANNER ;EP
- NEW BLSTEXT,BLSLINE,BLSX,BLSJ,BLS
- S BLSTEXT="TEXT",BLSLINE=3
- PRINT W:$D(IOF) @IOF
- F BLSJ=1:1:BLSLINE S BLSX=$T(@BLSTEXT+BLSJ),BLSX=$P(BLSX,";;",2) W !?80-$L(BLSX)\2,BLSX K BLSX
- SITE G XIT:'$D(DUZ(2)) G:'DUZ(2) XIT S BLS("SITE")=$P(^DIC(4,DUZ(2),0),"^") W !!?80-$L(BLS("SITE"))\2,BLS("SITE")
- XIT ;
- K DIC,DA,X,Y,%Y,%,BLSJ,BLSX,BLSTEXT,BLSLINE,BLS
- Q
- TEXT ;
- ;;*****************************
- ;;** IHS Lab Loinc Menu **
- ;;*****************************
- ;;QUIT
- BLSELL ; IHS/CMI/LAB - UPDATE TESTS TO EXPORT ; [ 12/19/2002 7:26 AM ]
- +1 ;;5.2;LR;**1015**;NOV 18, 2002
- +2 ;; ;
- EN ;EP -- main entry point for BLS LOINC TO EXPORT
- +1 DO EN^VALM("BLS LOINC TO EXPORT")
- +2 DO CLEAR^VALM1
- +3 DO FULL^VALM1
- +4 DO EXIT
- +5 QUIT
- +6 ;
- HDR ; -- header code
- +1 SET VALMHDR(1)="List of Lab Tests (by LOINC Code) that are currently being"
- +2 SET VALMHDR(2)="exported to CDC."
- +3 SET VALMHDR(3)="You may add a new code to the list or remove an existing code from the list."
- +4 QUIT
- +5 ;
- INIT ; -- init variables and list array
- +1 KILL BLSELL
- SET BLSC=0
- SET BLSX=0
- +2 FOR
- SET BLSX=$ORDER(^BLSELL(BLSX))
- IF BLSX'=+BLSX
- QUIT
- Begin DoDot:1
- +3 SET BLSC=BLSC+1
- SET BLSELL("IDX",BLSC,BLSC)=BLSX
- +4 SET BLSIEN=$PIECE(^BLSELL(BLSX,0),U)
- SET BLSELL(BLSC,0)=BLSC_")"
- SET $EXTRACT(BLSELL(BLSC,0),6)=$PIECE(^LAB(95.3,BLSIEN,0),U)
- SET $EXTRACT(BLSELL(BLSC,0),13)=$PIECE($GET(^LAB(95.3,BLSIEN,80)),U)
- End DoDot:1
- +5 SET VALMCNT=BLSC
- +6 QUIT
- +7 ;
- HELP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ; -- exit code
- +1 DO EN^XBVK("BLS")
- +2 DO ^XBFMK
- +3 QUIT
- +4 ;
- EXPND ; -- expand code
- +1 QUIT
- +2 ;
- EOP ;EP - End of page.
- +1 IF $EXTRACT(IOST)'="C"
- QUIT
- +2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
- QUIT
- +3 NEW DIR
- +4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
- +5 SET DIR(0)="E"
- DO ^DIR
- +6 QUIT
- +7 ;----------
- 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
- DO ^XBFMK
- +7 QUIT
- +8 ;
- ADD ;EP - add an item to the selected list - called from a protocol
- +1 DO FULL^VALM1
- +2 WRITE !,"Adding new Lab Test (LOINC code) to the exported lab test list....",!
- +3 DO ^XBFMK
- +4 SET DIC="^BLSELL("
- SET DIC(0)="AEMQL"
- DO ^DIC
- +5 DO BACK
- +6 QUIT
- +7 ;
- REM ;
- +1 DO FULL^VALM1
- +2 NEW LIEN
- +3 SET LIEN=0
- +4 ;this list man call allows user to select an entry in list
- DO EN^VALM2(XQORNOD(0),"OS")
- +5 IF '$DATA(VALMY)
- WRITE !,"No Loinc Code selected."
- GOTO REMX
- +6 SET LIEN=$ORDER(VALMY(0))
- IF 'LIEN
- KILL LIEN,VALMY,XQORNOD
- WRITE !,"No Loinc Code selected."
- GOTO REMX
- +7 SET LIEN=BLSELL("IDX",LIEN,LIEN)
- +8 IF '$DATA(^BLSELL(LIEN,0))
- WRITE !,"Not a valid LOINC ENTRY."
- KILL LIEN
- SET LIEN=0
- GOTO REMX
- +9 WRITE !!,"Deleting LOINC code "_$PIECE(^LAB(95.3,$PIECE(^BLSELL(LIEN,0),U),0),U)_" from list of exported Lab Tests.",!
- +10 SET DA=LIEN
- SET DIK="^BLSELL("
- DO ^DIK
- +11 KILL DIK
- REMX ;
- +1 DO EOP
- +2 KILL DIR
- +3 KILL LIEN
- +4 DO BACK
- +5 QUIT
- +6 ;
- BANNER ;EP
- +1 NEW BLSTEXT,BLSLINE,BLSX,BLSJ,BLS
- +2 SET BLSTEXT="TEXT"
- SET BLSLINE=3
- PRINT IF $DATA(IOF)
- WRITE @IOF
- +1 FOR BLSJ=1:1:BLSLINE
- SET BLSX=$TEXT(@BLSTEXT+BLSJ)
- SET BLSX=$PIECE(BLSX,";;",2)
- WRITE !?80-$LENGTH(BLSX)\2,BLSX
- KILL BLSX
- SITE IF '$DATA(DUZ(2))
- GOTO XIT
- IF 'DUZ(2)
- GOTO XIT
- SET BLS("SITE")=$PIECE(^DIC(4,DUZ(2),0),"^")
- WRITE !!?80-$LENGTH(BLS("SITE"))\2,BLS("SITE")
- XIT ;
- +1 KILL DIC,DA,X,Y,%Y,%,BLSJ,BLSX,BLSTEXT,BLSLINE,BLS
- +2 QUIT
- TEXT ;
- +1 ;;*****************************
- +2 ;;** IHS Lab Loinc Menu **
- +3 ;;*****************************
- +4 ;;QUIT
