BLRCCPED.m

BLRCCPED ; IHS/MSC/MKK - CC Parameter EDit  ; 22-Oct-2013 09:22 ; MKK

 ;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997

 ;

EEP ; Ersatz EP

 D EEP^BLRGMENU

 Q

 ;

PEP ; EP

CHANGE ; EP

 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 ;

 S HEADER(1)="IHS Laboratory"

 S HEADER(2)="BLR CC DATA Parameter"

 S HEADER(3)=$$CJ^XLFSTR("Modify Value",IOM)

 ;

 S RESULT=$$GET^XPAR("PKG","BLR CC DATA",1,"Q")

 S RESULT=$S(RESULT:"YES",RESULT=0:"NO",1:"")

 ;

 D HEADERDT^BLRGMENU

 ;

 D ^XBFMK

 S DIR(0)="YO"

 S DIR("A")="BLR CC DATA (YES/NO)"

 S:$L(RESULT) DIR("B")=RESULT

 D ^DIR

 ;

 I +$G(DIRUT)!($G(Y)="") D  Q

 . W !!,?4,"Invalid/No Entry/Quit. Routine Ends."

 . D PRESSKEY^BLRGMENU(9)

 ;

 S ANSWER=$S($E(X)="Y":"YES",1:"NO")

 ;

 D EN^XPAR("PKG","BLR CC DATA",,ANSWER,.ERRS)

 ;

 D:+$G(ERRS)>0 RPTERR(ERRS)

 ;

 Q

 ;

RPTERR(ERROR) ; EP

 NEW ERRDESC,ERRNUM,NOWH

 ;

 S ERRNUM=$P(ERROR,"^")

 S ERRDESC=$P(ERROR,"^",2)

 ;

 W !!,"*** ERROR Modifying BLR CC DATA paramter. ***",!!

 W ?4,"Error Number:",ERRNUM,!

 W:$L(ERRDESC)<50 ?9,"Description:",ERRDESC

 I $L(ERRDESC)>49 D LINEWRAP^BLRGMENU(9,ERRDESC,60)

 W !

 ;

 D PRESSKEY^BLRGMENU(9)

 ;

 S NOWH=$H

 S:$D(^XTMP("BLRCCPED"))<1 XTMP("BLRCCPED")="^"_$$DT^XLFDT_"^Errors Modifying BLR CC DATA Parameter"

 S $P(^XTMP("BLRCCPED"),"^")=$$HTFM^XLFDT(+$H+30)

 ;

 M ^XTMP("BLRCCPED",NOWH,"01","DUZ")=DUZ

 S ^XTMP("BLRCCPED",NOWH,"02","ERROR")=ERROR

 ;

 Q

 ;

GETCCDTO(LRODT,LRSP,LRTST) ; EP - Get CC Data; called from LROW2A

 NEW LRAA,LRAD,LRAN,LRDFN,LRSS,LRIDT

 ;

 S STR=$G(^LRO(69,LRODT,1,LRSP,2,LRTST,0))

 S LRAA=+$P(STR,"^",4)  Q:$L(LRAA)<1

 ;

 S LRSS=$$GET1^DIQ(68,LRAA,.02,"I")

 Q:$L(LRSS)<1

 ;

 S LRAD=+$P(STR,"^",3),LRAN=+$P(STR,"^",5)

 S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRIDT=+$P($G(^(3)),"^",5)

 Q:LRDFN<1!(LRIDT<1)

 ;

 D GETCCDTA(LRDFN,LRSS,LRIDT)

 Q

 ;

GETCCDTA(LRDFN,LRSS,LRIDT) ; EP - Get CC Data; Called from LRVER4

 NEW CCIEN,CCNAME,CCSTR,FDA,ERRS,HEADER,IENS,RESULT,WOTSUBF

 ;

 ;

 ; S HEADER(1)="IHS Laboratory"

 ; S HEADER(2)="BLR CC DATA Parameter"

 ;

 S RESULT=+$$GET^XPAR("PKG","BLR CC DATA",1,"Q")

 Q:'RESULT

 ;

 D ^XBFMK

 S DIR(0)="YO"

 ; S DIR("A")="CC Patient's Accession Data"

 S DIR("A")="CC Patient Results"

 S DIR("B")="NO"

 D ^DIR

 Q:+$D(DIRUT)!(+$G(Y)<1)

 ;

 W !!

 ;

 D ^XBFMK

 S DIR(0)="PO^200:E"

 S DIR("A")="Provider to CC"

 D ^DIR

 I +$D(DIRUT)!($G(X)="") D

 . W !,?4,"Invalid/No/Quit Input.  Routine Ends."

 . D PRESSKEY^BLRGMENU(9)

 ;

 S CCIEN=+Y,CCNAME=$P(Y,"^",2)

 S CCSTR=CCNAME_"!"_CCIEN_"!"_DUZ_"!"_$$NOW^XLFDT

 ;

 ; Set Sub-File Number

 S WOTSUBF=$S(LRSS="CH":63.04,LRSS="MI":63.05)

 ;

 S IENS=","_LRIDT_","_LRDFN_","

 S FDA(WOTSUBF,IENS,9999992)=CCSTR

 D UPDATE^DIE("S","FDA",,"ERRS")

 ;

 Q

 ;

YEXPORTD(LRDFN,LRSS,LRIDT) ; EP - Put YES into EXPORTED DATA field in file 63

 NEW ERRS,FDA,IENS

 ;

 S IENS=LRIDT_","_LRDFN_","

 ;

 ; Set Sub-File Number

 S WOTSUBF=$S(LRSS="CH":63.04,LRSS="MI":63.05)

 ;

 S FDA(WOTSUBF,IENS,"EXPORTED DATA")="Y"

 D UPDATE^DIE("S","FDA",,"ERRS")

 Q

 ;

AYEXPORT(LRAS) ; EP - Given an accession number, call YEXPORTD

 NEW IENS,LRAA,LRAD,LRAN,LRDFN,LRIDT,LRSS

 ;

 Q:$$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)<1

 ;

 S LRSS=$$GET1^DIQ(68,LRAA,"LR SUBSCRIPT","I")

 S IENS=LRAN_","_LRAD_","_LRAA

 S LRDFN=$$GET1^DIQ(68.02,IENS,"LRDFN")

 S LRIDT=$$GET1^DIQ(68.02,IENS,"INVERSE DATE","I")

 ;

 D YEXPORTD(LRDFN,LRSS,LRIDT)

 Q

 ;

UYEXPORT(UID) ; EP - Given an UID, call YEXPORTD

 NEW IENS,LRAA,LRAD,LRAN,LRDFN,LRIDT,LRSS

 D RETACCV^BLRUTIL4(UID,.LRAA,.LRAD,.LRAN,.LRDFN,.LRSS,.LRIDT)

 S LRSS=$$GET1^DIQ(68,LRAA,.02,"I")      ; Need to reset LRSS

 ;

 D YEXPORTD(LRDFN,LRSS,LRIDT)

 Q

BLRCCPED  ; IHS/MSC/MKK - CC Parameter EDit  ; 22-Oct-2013 09:22 ; MKK

 +1       ;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997

 +2       ;

EEP       ; Ersatz EP

 +1        DO EEP^BLRGMENU

 +2        QUIT 

 +3       ;

PEP       ; EP

CHANGE    ; EP

 +1        NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)

 +2       ;

 +3        SET HEADER(1)="IHS Laboratory"

 +4        SET HEADER(2)="BLR CC DATA Parameter"

 +5        SET HEADER(3)=$$CJ^XLFSTR("Modify Value",IOM)

 +6       ;

 +7        SET RESULT=$$GET^XPAR("PKG","BLR CC DATA",1,"Q")

 +8        SET RESULT=$SELECT(RESULT:"YES",RESULT=0:"NO",1:"")

 +9       ;

 +10       DO HEADERDT^BLRGMENU

 +11      ;

 +12       DO ^XBFMK

 +13       SET DIR(0)="YO"

 +14       SET DIR("A")="BLR CC DATA (YES/NO)"

 +15       IF $LENGTH(RESULT)

               SET DIR("B")=RESULT

 +16       DO ^DIR

 +17      ;

 +18       IF +$GET(DIRUT)!($GET(Y)="")

               Begin DoDot:1

 +19               WRITE !!,?4,"Invalid/No Entry/Quit. Routine Ends."

 +20               DO PRESSKEY^BLRGMENU(9)

               End DoDot:1

               QUIT 

 +21      ;

 +22       SET ANSWER=$SELECT($EXTRACT(X)="Y":"YES",1:"NO")

 +23      ;

 +24       DO EN^XPAR("PKG","BLR CC DATA",,ANSWER,.ERRS)

 +25      ;

 +26       IF +$GET(ERRS)>0

               DO RPTERR(ERRS)

 +27      ;

 +28       QUIT 

 +29      ;

RPTERR(ERROR) ; EP

 +1        NEW ERRDESC,ERRNUM,NOWH

 +2       ;

 +3        SET ERRNUM=$PIECE(ERROR,"^")

 +4        SET ERRDESC=$PIECE(ERROR,"^",2)

 +5       ;

 +6        WRITE !!,"*** ERROR Modifying BLR CC DATA paramter. ***",!!

 +7        WRITE ?4,"Error Number:",ERRNUM,!

 +8        IF $LENGTH(ERRDESC)<50

               WRITE ?9,"Description:",ERRDESC

 +9        IF $LENGTH(ERRDESC)>49

               DO LINEWRAP^BLRGMENU(9,ERRDESC,60)

 +10       WRITE !

 +11      ;

 +12       DO PRESSKEY^BLRGMENU(9)

 +13      ;

 +14       SET NOWH=$HOROLOG

 +15       IF $DATA(^XTMP("BLRCCPED"))<1

               SET XTMP("BLRCCPED")="^"_$$DT^XLFDT_"^Errors Modifying BLR CC DATA Parameter"

 +16       SET $PIECE(^XTMP("BLRCCPED"),"^")=$$HTFM^XLFDT(+$HOROLOG+30)

 +17      ;

 +18       MERGE ^XTMP("BLRCCPED",NOWH,"01","DUZ")=DUZ

 +19       SET ^XTMP("BLRCCPED",NOWH,"02","ERROR")=ERROR

 +20      ;

 +21       QUIT 

 +22      ;

GETCCDTO(LRODT,LRSP,LRTST) ; EP - Get CC Data; called from LROW2A

 +1        NEW LRAA,LRAD,LRAN,LRDFN,LRSS,LRIDT

 +2       ;

 +3        SET STR=$GET(^LRO(69,LRODT,1,LRSP,2,LRTST,0))

 +4        SET LRAA=+$PIECE(STR,"^",4)

           IF $LENGTH(LRAA)<1

               QUIT 

 +5       ;

 +6        SET LRSS=$$GET1^DIQ(68,LRAA,.02,"I")

 +7        IF $LENGTH(LRSS)<1

               QUIT 

 +8       ;

 +9        SET LRAD=+$PIECE(STR,"^",3)

           SET LRAN=+$PIECE(STR,"^",5)

 +10       SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))

           SET LRIDT=+$PIECE($GET(^(3)),"^",5)

 +11       IF LRDFN<1!(LRIDT<1)

               QUIT 

 +12      ;

 +13       DO GETCCDTA(LRDFN,LRSS,LRIDT)

 +14       QUIT 

 +15      ;

GETCCDTA(LRDFN,LRSS,LRIDT) ; EP - Get CC Data; Called from LRVER4

 +1        NEW CCIEN,CCNAME,CCSTR,FDA,ERRS,HEADER,IENS,RESULT,WOTSUBF

 +2       ;

 +3       ;

 +4       ; S HEADER(1)="IHS Laboratory"

 +5       ; S HEADER(2)="BLR CC DATA Parameter"

 +6       ;

 +7        SET RESULT=+$$GET^XPAR("PKG","BLR CC DATA",1,"Q")

 +8        IF 'RESULT

               QUIT 

 +9       ;

 +10       DO ^XBFMK

 +11       SET DIR(0)="YO"

 +12      ; S DIR("A")="CC Patient's Accession Data"

 +13       SET DIR("A")="CC Patient Results"

 +14       SET DIR("B")="NO"

 +15       DO ^DIR

 +16       IF +$DATA(DIRUT)!(+$GET(Y)<1)

               QUIT 

 +17      ;

 +18       WRITE !!

 +19      ;

 +20       DO ^XBFMK

 +21       SET DIR(0)="PO^200:E"

 +22       SET DIR("A")="Provider to CC"

 +23       DO ^DIR

 +24       IF +$DATA(DIRUT)!($GET(X)="")

               Begin DoDot:1

 +25               WRITE !,?4,"Invalid/No/Quit Input.  Routine Ends."

 +26               DO PRESSKEY^BLRGMENU(9)

               End DoDot:1

 +27      ;

 +28       SET CCIEN=+Y

           SET CCNAME=$PIECE(Y,"^",2)

 +29       SET CCSTR=CCNAME_"!"_CCIEN_"!"_DUZ_"!"_$$NOW^XLFDT

 +30      ;

 +31      ; Set Sub-File Number

 +32       SET WOTSUBF=$SELECT(LRSS="CH":63.04,LRSS="MI":63.05)

 +33      ;

 +34       SET IENS=","_LRIDT_","_LRDFN_","

 +35       SET FDA(WOTSUBF,IENS,9999992)=CCSTR

 +36       DO UPDATE^DIE("S","FDA",,"ERRS")

 +37      ;

 +38       QUIT 

 +39      ;

YEXPORTD(LRDFN,LRSS,LRIDT) ; EP - Put YES into EXPORTED DATA field in file 63

 +1        NEW ERRS,FDA,IENS

 +2       ;

 +3        SET IENS=LRIDT_","_LRDFN_","

 +4       ;

 +5       ; Set Sub-File Number

 +6        SET WOTSUBF=$SELECT(LRSS="CH":63.04,LRSS="MI":63.05)

 +7       ;

 +8        SET FDA(WOTSUBF,IENS,"EXPORTED DATA")="Y"

 +9        DO UPDATE^DIE("S","FDA",,"ERRS")

 +10       QUIT 

 +11      ;

AYEXPORT(LRAS) ; EP - Given an accession number, call YEXPORTD

 +1        NEW IENS,LRAA,LRAD,LRAN,LRDFN,LRIDT,LRSS

 +2       ;

 +3        IF $$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)<1

               QUIT 

 +4       ;

 +5        SET LRSS=$$GET1^DIQ(68,LRAA,"LR SUBSCRIPT","I")

 +6        SET IENS=LRAN_","_LRAD_","_LRAA

 +7        SET LRDFN=$$GET1^DIQ(68.02,IENS,"LRDFN")

 +8        SET LRIDT=$$GET1^DIQ(68.02,IENS,"INVERSE DATE","I")

 +9       ;

 +10       DO YEXPORTD(LRDFN,LRSS,LRIDT)

 +11       QUIT 

 +12      ;

UYEXPORT(UID) ; EP - Given an UID, call YEXPORTD

 +1        NEW IENS,LRAA,LRAD,LRAN,LRDFN,LRIDT,LRSS

 +2        DO RETACCV^BLRUTIL4(UID,.LRAA,.LRAD,.LRAN,.LRDFN,.LRSS,.LRIDT)

 +3       ; Need to reset LRSS

           SET LRSS=$$GET1^DIQ(68,LRAA,.02,"I")

 +4       ;

 +5        DO YEXPORTD(LRDFN,LRSS,LRIDT)

 +6        QUIT