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
