- LRTSTJAN ;VA/SLC/RWF,DCN-JAM TESTS ONTO (OR OFF) ACCESSIONS PART2 ;8/11/97
- ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
- ;
- ;;VA LR Patch(s): 67,100,121,128,202,221,337
- ;
- DELOG ;This tag is no longer available - Routine LRTSTOUT replaces this call.
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- S BLROPT="REMACC"
- ;----- END IHS MODIFICATIONS
- W @IOF,!,$$CJ^XLFSTR(" The ability to DELETE an entire ORDER/ACCESSION ",80)
- W $$CJ^XLFSTR("has been REPLACED. The test(s) will now be marked",80)
- W $$CJ^XLFSTR("as Not Performed and a reason for 'NP' will be stored",80)
- W $$CJ^XLFSTR("with each test. Accession numbers can't be reused",80)
- W $$CJ^XLFSTR("after it has been assigned to a specimen.",80)
- EN D ^LRPARAM G:$G(LREND) END
- I '$D(LRLABKY) W !?5,"You are not authorized to change test status.",! G END
- K LRSCNXB
- EN1 ;
- N LRTOTL,LRIFN
- S (LREND,LRNOP)=0 K LRNATURE
- D FIX^LRTSTOUT G END:$G(LREND) I $G(LRNOP) D END G EN1
- W ! K DIR S DIR(0)="Y",DIR("A")=" Change Entire accession to Not Perform !! ",DIR("B")="NO" D ^DIR K DIR
- I $D(DIRUT) G EN1
- S LRTOTL=Y,LRIFN=0
- I LRTOTL>0 D
- .F S LRIFN=$O(^LR(LRDFN,LRSS,LRIDT,LRIFN)) Q:LRIFN="" S:$P($G(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending" $P(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)=""
- ;I Y=0 D CHG^LRTSTOUT W !!! G EN1
- I LRTOTL=0 D CHG^LRTSTOUT W !!! G EN1
- D FX2^LRTSTOUT I $G(LREND) D END W @IOF G EN1
- D
- . N LRTSTS
- . S LRTSTS=0,LRNOW=$$NOW^XLFDT F S LRTSTS=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS)) Q:LRTSTS<1 I $D(^(LRTSTS,0))#2,'$P(^(0),U,5) D
- . . I $D(^LAB(60,LRTSTS,0)) S LRTNM=$P(^(0),U) D SET^LRTSTOUT
- L -^LRO(68,LRAA,1,LRAD,1,LRAN)
- I $L($G(LRSS)) L -^LR(+$G(LRDFN),LRSS,+$G(LRIDT))
- W @IOF,!!,"All accessioned test(s) changed",!!
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- D:BLRLOG ^BLREVTQ("M","D",$G(BLROPT),,LRACN)
- ;----- END IHS MODIFICATIONS
- D END G EN1
- Q
- END K LRWRD,LRWDT1,LRTREA,LRRB,LRPRAC,LREND,LRAA,LRAD,LRAN,LRACC,LRTEST,LRTSTN,LRNATURE,LRX,LRIDIV,LRSAMP,LRGCOM,LRCOM,LRTCOM,LRDFN,LRDPF,LRACD,LRACN,LRACN0,LRDOC,LRLL,LROD0,LROD1,LROD3,LRODT,LROOS,LROS,LROSD,LROT,LRROD,LRSN,LRTSTS,LRTT,LRWL1
- K LRF,LRI,LRJ,LRMSTATI
- K I,X,X1,X2,X3,X4,DA,DR,DIC,DFN,AGE,DOB,PNM,SSN,VAIN,VADM,VAERR,VA,VA200,SSN,SEX
- K HRCN ; IHS/MSC/MKK - LR*5.2*1031
- D END^LRTSTOUT
- Q
- ULK ;Unlock ^LRO(68,
- I ($G(LRAA)&($G(LRAD))&($G(LRAN))) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
- Q
- NEWSTART ;Set new starting accession #
- N LRAA,LRAD,LRAN,LRIDIV,LRX,LRACC,LREND,LRNEW
- S LREND=0
- D ^LRWU4 Q:LRAD<1
- N1 G NEWSTART:'$D(^LRO(68,LRAA,1,LRAD,1,0))
- R !,"""Next"" accession number: ",LRNEW:DTIME
- G NEWSTART:LRNEW="^"!(LRNEW="")
- K:(LRNEW<1)!(LRNEW>999999)!(LRNEW'=+LRNEW) LRNEW S:$D(LRNEW) LRNEW=LRNEW-1
- I '$D(LRNEW) W !,"Must be whole number between 1 and 999999, accession remains unchanged." G N1
- S $P(^LRO(68,LRAA,1,LRAD,1,0),U,3)=LRNEW
- G NEWSTART
- US ;ck if units selected
- S A=0 F S A=$O(^LR(LRDFN,1.8,A)) Q:A<1!($D(C)) S B=0 F S B=$O(^LR(LRDFN,1.8,A,1,B)) Q:B<1!($D(C)) I $P(^(B,0),"^",2)=LRIDT S C=1 Q
- Q
- OE ;
- I $$VER^LR7OU1<3 S ORIFN=$P(LRTS,"^",7) I ORIFN D DC^LRCENDE1
- I $L($G(LRGCOM)),$L($P($G(LRNATURE),"^",5)),$P(LRNATURE,"^",5)'["=>" S $P(LRNATURE,"^",5)=LRCM
- N I S:$G(LRTS) I(+LRTS)="" D NEW^LR7OB1(LRODT,LRSN,$S($G(LRMSTATI)=""!($G(LRMSTATI)=1):"OC",1:"SC"),$G(LRNATURE),.I,$G(LRMSTATI))
- Q
- LRACC S LREND=0 D ^LRWU4 S DA(2)=LRAA,DA(1)=LRAD
- Q
- LRTSTJAN ;VA/SLC/RWF,DCN-JAM TESTS ONTO (OR OFF) ACCESSIONS PART2 ;8/11/97
- +1 ;;5.2;LAB SERVICE;**1031**;NOV 1, 1997
- +2 ;
- +3 ;;VA LR Patch(s): 67,100,121,128,202,221,337
- +4 ;
- DELOG ;This tag is no longer available - Routine LRTSTOUT replaces this call.
- +1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +2 SET BLROPT="REMACC"
- +3 ;----- END IHS MODIFICATIONS
- +4 WRITE @IOF,!,$$CJ^XLFSTR(" The ability to DELETE an entire ORDER/ACCESSION ",80)
- +5 WRITE $$CJ^XLFSTR("has been REPLACED. The test(s) will now be marked",80)
- +6 WRITE $$CJ^XLFSTR("as Not Performed and a reason for 'NP' will be stored",80)
- +7 WRITE $$CJ^XLFSTR("with each test. Accession numbers can't be reused",80)
- +8 WRITE $$CJ^XLFSTR("after it has been assigned to a specimen.",80)
- EN DO ^LRPARAM
- IF $GET(LREND)
- GOTO END
- +1 IF '$DATA(LRLABKY)
- WRITE !?5,"You are not authorized to change test status.",!
- GOTO END
- +2 KILL LRSCNXB
- EN1 ;
- +1 NEW LRTOTL,LRIFN
- +2 SET (LREND,LRNOP)=0
- KILL LRNATURE
- +3 DO FIX^LRTSTOUT
- IF $GET(LREND)
- GOTO END
- IF $GET(LRNOP)
- DO END
- GOTO EN1
- +4 WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")=" Change Entire accession to Not Perform !! "
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- +5 IF $DATA(DIRUT)
- GOTO EN1
- +6 SET LRTOTL=Y
- SET LRIFN=0
- +7 IF LRTOTL>0
- Begin DoDot:1
- +8 FOR
- SET LRIFN=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRIFN))
- IF LRIFN=""
- QUIT
- IF $PIECE($GET(^LR(LRDFN,LRSS,LRIDT,LRIFN)),U)="pending"
- SET $PIECE(^LR(LRDFN,LRSS,LRIDT,LRIFN),U)=""
- End DoDot:1
- +9 ;I Y=0 D CHG^LRTSTOUT W !!! G EN1
- +10 IF LRTOTL=0
- DO CHG^LRTSTOUT
- WRITE !!!
- GOTO EN1
- +11 DO FX2^LRTSTOUT
- IF $GET(LREND)
- DO END
- WRITE @IOF
- GOTO EN1
- +12 Begin DoDot:1
- +13 NEW LRTSTS
- +14 SET LRTSTS=0
- SET LRNOW=$$NOW^XLFDT
- FOR
- SET LRTSTS=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTSTS))
- IF LRTSTS<1
- QUIT
- IF $DATA(^(LRTSTS,0))#2
- IF '$PIECE(^(0),U,5)
- Begin DoDot:2
- +15 IF $DATA(^LAB(60,LRTSTS,0))
- SET LRTNM=$PIECE(^(0),U)
- DO SET^LRTSTOUT
- End DoDot:2
- End DoDot:1
- +16 LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
- +17 IF $LENGTH($GET(LRSS))
- LOCK -^LR(+$GET(LRDFN),LRSS,+$GET(LRIDT))
- +18 WRITE @IOF,!!,"All accessioned test(s) changed",!!
- +19 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- +20 IF BLRLOG
- DO ^BLREVTQ("M","D",$GET(BLROPT),,LRACN)
- +21 ;----- END IHS MODIFICATIONS
- +22 DO END
- GOTO EN1
- +23 QUIT
- END KILL LRWRD,LRWDT1,LRTREA,LRRB,LRPRAC,LREND,LRAA,LRAD,LRAN,LRACC,LRTEST,LRTSTN,LRNATURE,LRX,LRIDIV,LRSAMP,LRGCOM,LRCOM,LRTCOM,LRDFN,LRDPF,LRACD,LRACN,LRACN0,LRDOC,LRLL,LROD0,LROD1,LROD3,LRODT,LROOS,LROS,LROSD,LROT,LRROD,LRSN,LRTSTS,LRTT,LRWL1
- +1 KILL LRF,LRI,LRJ,LRMSTATI
- +2 KILL I,X,X1,X2,X3,X4,DA,DR,DIC,DFN,AGE,DOB,PNM,SSN,VAIN,VADM,VAERR,VA,VA200,SSN,SEX
- +3 ; IHS/MSC/MKK - LR*5.2*1031
- KILL HRCN
- +4 DO END^LRTSTOUT
- +5 QUIT
- ULK ;Unlock ^LRO(68,
- +1 IF ($GET(LRAA)&($GET(LRAD))&($GET(LRAN)))
- LOCK -^LRO(68,LRAA,1,LRAD,1,LRAN)
- +2 QUIT
- NEWSTART ;Set new starting accession #
- +1 NEW LRAA,LRAD,LRAN,LRIDIV,LRX,LRACC,LREND,LRNEW
- +2 SET LREND=0
- +3 DO ^LRWU4
- IF LRAD<1
- QUIT
- N1 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,0))
- GOTO NEWSTART
- +1 READ !,"""Next"" accession number: ",LRNEW:DTIME
- +2 IF LRNEW="^"!(LRNEW="")
- GOTO NEWSTART
- +3 IF (LRNEW<1)!(LRNEW>999999)!(LRNEW'=+LRNEW)
- KILL LRNEW
- IF $DATA(LRNEW)
- SET LRNEW=LRNEW-1
- +4 IF '$DATA(LRNEW)
- WRITE !,"Must be whole number between 1 and 999999, accession remains unchanged."
- GOTO N1
- +5 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,0),U,3)=LRNEW
- +6 GOTO NEWSTART
- US ;ck if units selected
- +1 SET A=0
- FOR
- SET A=$ORDER(^LR(LRDFN,1.8,A))
- IF A<1!($DATA(C))
- QUIT
- SET B=0
- FOR
- SET B=$ORDER(^LR(LRDFN,1.8,A,1,B))
- IF B<1!($DATA(C))
- QUIT
- IF $PIECE(^(B,0),"^",2)=LRIDT
- SET C=1
- QUIT
- +2 QUIT
- OE ;
- +1 IF $$VER^LR7OU1<3
- SET ORIFN=$PIECE(LRTS,"^",7)
- IF ORIFN
- DO DC^LRCENDE1
- +2 IF $LENGTH($GET(LRGCOM))
- IF $LENGTH($PIECE($GET(LRNATURE),"^",5))
- IF $PIECE(LRNATURE,"^",5)'["=>"
- SET $PIECE(LRNATURE,"^",5)=LRCM
- +3 NEW I
- IF $GET(LRTS)
- SET I(+LRTS)=""
- DO NEW^LR7OB1(LRODT,LRSN,$SELECT($GET(LRMSTATI)=""!($GET(LRMSTATI)=1):"OC",1:"SC"),$GET(LRNATURE),.I,$GET(LRMSTATI))
- +4 QUIT
- LRACC SET LREND=0
- DO ^LRWU4
- SET DA(2)=LRAA
- SET DA(1)=LRAD
- +1 QUIT
