- ORWRP2 ;SLC/DCM - Health Summary Adhoc RPC's ;08/30/2017 11:49
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,109,212,309,332,377**;Dec 17, 1997;Build 582
- BB ;Continuation of Blood Bank Report
- N DFN,ORY,ORSBHEAD,GCNT,GIOM
- S DFN=ORDFN,GCNT=0,GIOM=80
- K ^TMP("LRC",$J)
- S ROOT=$NA(^TMP("LRC",$J))
- D BLEG
- Q
- BLEG ;Legacy VISTA Blood Bank Report
- S ORSBHEAD("BLOOD BANK")=""
- D EN^LR7OSUM(.ORY,DFN,,,,GIOM,.ORSBHEAD),TRAN
- I '$O(^TMP("LRC",$J,0)) S GCNT=GCNT+1,^TMP("LRC",$J,GCNT,0)="",GCNT=GCNT+1,^TMP("LRC",$J,GCNT,0)="No Blood Bank report available..."
- Q
- COMP(ORY) ;Get ADHOC sub components (FILE 142.1)
- ;RPC => ORWRP2 HS COMPONENTS
- ;Y(i)=(1)I;IFN^(2)Component Name [Abb]^(3)Occ Limit^(4)Time Limit^(5)Header Name^
- ; (6)Hosp Loc Disp^(7)ICD Text Disp^(8)Prov Narr Disp^(9)Summary Order
- D COMP^GMTSADH5(.ORY)
- Q
- ;
- COMPABV(ORY) ;Get ADHOC sub components listed by Abbreviation
- N I,X,X1,X2,X3
- D COMP^GMTSADH5(.ORY)
- S I=0
- F S I=$O(ORY(I)) Q:'I S X=ORY(I) D
- . S X1=$P($P(X,"^",2),"["),X1=$E(X1,1,$L(X1)-1),X2=$P($P(X,"^",2),"[",2),X2=$E(X2,1,$L(X2)-1)
- . S:'$L(X2) X2="???" S:'$L($P(X,"^",5)) $P(X,"^",5)=$P($P(X,"^",2),"[") ;***
- . S X3=X2_" - "_$P(X,"^",5)_" ",$P(ORY(I),"^",2)=X3
- Q
- COMPDISP(ORY) ;Get ADHOC sub components listed by Display Name
- N I,X,X1,X2,X3
- D COMP^GMTSADH5(.ORY)
- S I=0
- F S I=$O(ORY(I)) Q:'I S X=ORY(I) D
- . S X1=$P($P(X,"^",2),"["),X1=$E(X1,1,$L(X1)-1),X2=$P($P(X,"^",2),"[",2),X2=$E(X2,1,$L(X2)-1)
- . S:'$L(X2) X2="???" S:'$L($P(X,"^",5)) $P(X,"^",5)=$P($P(X,"^",2),"[") ;***
- . S X3=$P(X,"^",5)_" ["_X2_"]",$P(ORY(I),"^",2)=X3
- Q
- COMPSUB(ORY,ORSUB) ;Get subitems from a predefined Adhoc component
- I '$L($T(COMPSUB^GMTSADH5)) Q
- D COMPSUB^GMTSADH5(.ORY,ORSUB)
- Q
- ;
- SAVLKUP(OK,VAL) ;save Adhoc lookup selection
- N ORERR
- S OK=""
- D EN^XPAR(DUZ_";VA(200,","ORWRP ADHOC LOOKUP",1,VAL,.ORERR)
- I ORERR S OK=VAL_":"_ORERR
- Q
- GETLKUP(ORY) ;Get Adhoc lookup selection
- S ORY=$$GET^XPAR("ALL","ORWRP ADHOC LOOKUP",1,"I")
- Q
- FILES(ORY,ORCOMP) ;Get Files to select from for a component
- ;RPC => ORWRP2 HS COMP FILES
- D FILES^GMTSADH5(.ORY,ORCOMP)
- Q
- ;
- FILESEL(OROOT,ORFILE,ORFROM,ORDIR) ;Get file entries for Combobox
- ;RPC => ORWRP2 HS FILE LOOKUP
- D FILESEL^GMTSADH5(.OROOT,ORFILE,ORFROM,ORDIR)
- Q
- ;
- REPORT(OROOT,ORCOMPS,ORDFN) ;Build Report from array of Components passed in COMPS
- ;RPC => ORWRP2 HS REPORT TEXT
- ;ORCOMPS(i)=array of subcomponents chosen, value is pointer at ^GMT(142,DA(1),1,DA)
- Q:'$G(ORDFN)
- N GMTSEGC,GMTSEG,ORGMTSEG,ORSEGC,ORSEGI
- K ^TMP("ORDATA",$J)
- D REPORT^GMTSADH5(.ORGMTSEG,.ORSEGC,.ORSEGI,.ORCOMPS,.ORDFN)
- Q:'$O(ORGMTSEG(0))
- D START^ORWRP(80,"REPORT1^ORWRP2(.ORGMTSEG,.ORSEGC,.ORSEGI,ORDFN)")
- S OROOT=$NA(^TMP("ORDATA",$J,1))
- Q
- REPORT1(GMTSEG,GMTSEGC,GMTSEGI,DFN) ;
- N GMTS,GMTS1,GMTS2,GMTSAGE,GMTSDOB,GMTSDTM,GMTSLO,GMTSLPG,GMTSPHDR,GMTSPNM,GMTSRB,GMTSSN,GMTSWRD
- N CNT,INC,ORVP,ROOT,SEX,VADM,VAERR,VAIN
- S ORVP=DFN
- D ADHOC^ORPRS13
- Q
- ;
- SUBITEM(ORY,ORTEST) ;Get Subitems for a Test Panel
- ;RPC => ORWRP2 HS SUBITEMS
- D SUBITEM^GMTSADH5(.ORY,ORTEST)
- Q
- PREPORT(OROOT,ORCOMPS,ORDFN) ;Build Report & Print
- ;Called from File|Print on Reports Tab after selecting ADHOC Health Summary
- ;COMPS(i)=array of subcomponents chosen, value is pointer at ^GMT(142,DA(1),1,DA)
- Q:'$G(ORDFN)
- N GMTSEGC,GMTSEG,ORGMTSEG,ORSEGC,ORSEGI
- D REPORT^GMTSADH5(.ORGMTSEG,.ORSEGC,.ORSEGI,.ORCOMPS,.ORDFN)
- Q:'$O(ORGMTSEG(0))
- M GMTSEG=ORGMTSEG,GMTSEGC=ORSEGC,GMTSEGI=ORSEGI
- N GMTS,GMTS1,GMTS2,GMTSAGE,GMTSDOB,GMTSDTM,GMTSLO,GMTSLPG,GMTSPHDR,GMTSPNM,GMTSRB,GMTSSN,GMTSWRD
- N CNT,INC,ORVP,ROOT,SEX,VADM,VAERR,VAIN
- S ORVP=ORDFN
- D ADHOC^ORPRS13
- Q
- TRAN ;Get Transfused Units
- N LRDFN,IDT,CNTR,TR,PN,PRODUCT,IX,GMI,X,BPN
- S:'$D(GMTS1) GMTS1=6666666 S:'$D(GMTS2) GMTS2=9999999
- K ^TMP("LRT",$J)
- Q:'$D(^DPT(DFN,"LR")) S LRDFN=+^DPT(DFN,"LR"),IDT=GMTS1-1
- I '$D(^LR(LRDFN)) Q
- S IDT=0 F S IDT=$O(^LR(LRDFN,1.6,IDT)) Q:+IDT'>0 D
- . S TR=$G(^LR(LRDFN,1.6,IDT,0)) D SET
- S IDT=0 F S IDT=$O(CNTR(IDT)) Q:+IDT'>0 D
- . S ^TMP("LRT",$J,IDT)=9999999-IDT_U,PN=0
- . F S PN=$O(CNTR(IDT,PN)) Q:PN'>0 D
- .. S PRODUCT=$G(^LAB(66,+PN,0)),^TMP("LRT",$J,$P(PRODUCT,U,2))=$P(PRODUCT,U)
- .. S ^TMP("LRT",$J,IDT)=^TMP("LRT",$J,IDT)_CNTR(IDT,PN)_"\"_$P(PRODUCT,U,2)_";"
- Q:'$O(^TMP("LRT",$J,0))
- S GCNT=+$O(^TMP("LRC",$J,999999999),-1)
- D LINE,LN
- S ^TMP("LRC",$J,GCNT,0)=$$S(0,CCNT,"Transfused Units"),IX=""
- F S IX=$O(^TMP("LRT",$J,IX)) Q:IX="" D
- . S GMR=^TMP("LRT",$J,IX),TD=$$FMTE^XLFDT(+GMR)
- . Q:TD=0
- . S GMA(1)=$P(GMR,U,2),BPN=$L(GMA(1),";")
- . I $P(GMA(1),";",BPN)="" S BPN=BPN-1
- . F GMI=2:1:BPN S GMA(GMI)="("_$P($P(GMA(1),";",GMI),"\")_") "_$P($P(GMA(1),";",GMI),"\",2)
- . S GMA(1)="("_$P($P(GMA(1),";",1),"\")_") "_$P($P(GMA(1),";",1),"\",2)
- . D WRT
- D KEY
- K ^TMP("LRT",$J)
- Q
- WRT ; Writes the Transfusion Record for each day
- N GML,GMI1,GMI2,GMM,GMJ,CL
- S GMM=$S(BPN#4:1,1:0),GML=BPN\4+GMM
- D LN S ^TMP("LRC",$J,GCNT,0)=$$S(2,.CCNT,TD)
- F GMI1=1:1:GML D
- . F GMI2=1:1:($S((GMI1=GML)&(BPN#4):BPN#4,1:4)) D
- .. S GMJ=((GMI1-1)*4)+GMI2,CL=(((GMI2-1)*15)+14)
- .. S ^TMP("LRC",$J,GCNT,0)=$G(^TMP("LRC",$J,GCNT,0))_$$S(CL,.CCNT,GMA(GMJ))
- .. I $S(GMI2#4=0:1,GMI2=BPN:1,GMI2+(4*(GMI1-1))=BPN:1,1:0) D LN
- Q
- SET ; Save Appropriate Data
- N COMP,UNITS,TDT,ITDT
- S TDT=9999999-IDT,ITDT=9999999-$P(TDT,".")
- S UNITS=+$P(TR,U,7) S:UNITS'>0 UNITS=1
- S CNTR(ITDT,+$P(TR,U,2))=+$G(CNTR(ITDT,+$P(TR,U,2)))+UNITS
- Q
- KEY ;
- I $O(^TMP("LRT",$J,"A"))'="" D
- . D LN
- . S ^TMP("LRC",$J,GCNT,0)=$$S(0,CCNT," Blood Product Key: ")
- S GMI="A" F S GMI=$O(^TMP("LRT",$J,GMI)) Q:GMI="" D
- . S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$$S(22,CCNT,GMI_" = "_$G(^TMP("LRT",$J,GMI)))
- . D LN
- . S ^TMP("LRC",$J,GCNT,0)=""
- Q
- LN ;
- S GCNT=GCNT+1,CCNT=1
- Q
- LINE ;Fill in the global with bank lines
- N X
- D LN
- S X="",$P(X," ",GIOM)="",^TMP("LRC",$J,GCNT,0)=X
- Q
- S(X,Y,Z) ;Pad over
- ;X=Column #
- ;Y=Current length
- ;Z=Text
- ;SP=TEXT SENT
- ;CCNT=Line position after input text
- I '$D(Z) Q ""
- S SP=Z I X,Y,X>Y S SP=$E(" ",1,X-Y)_Z
- S CCNT=$$INC(CCNT,SP)
- Q SP
- INC(X,Y) ;Character position count
- ;X=Current count
- ;Y=Text
- S INC=X+$L(Y)
- Q INC
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWRP2 6272 printed Jan 18, 2025@03:38:28 Page 2
- ORWRP2 ;SLC/DCM - Health Summary Adhoc RPC's ;08/30/2017 11:49
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,109,212,309,332,377**;Dec 17, 1997;Build 582
- BB ;Continuation of Blood Bank Report
- +1 NEW DFN,ORY,ORSBHEAD,GCNT,GIOM
- +2 SET DFN=ORDFN
- SET GCNT=0
- SET GIOM=80
- +3 KILL ^TMP("LRC",$JOB)
- +4 SET ROOT=$NAME(^TMP("LRC",$JOB))
- +5 DO BLEG
- +6 QUIT
- BLEG ;Legacy VISTA Blood Bank Report
- +1 SET ORSBHEAD("BLOOD BANK")=""
- +2 DO EN^LR7OSUM(.ORY,DFN,,,,GIOM,.ORSBHEAD)
- DO TRAN
- +3 IF '$ORDER(^TMP("LRC",$JOB,0))
- SET GCNT=GCNT+1
- SET ^TMP("LRC",$JOB,GCNT,0)=""
- SET GCNT=GCNT+1
- SET ^TMP("LRC",$JOB,GCNT,0)="No Blood Bank report available..."
- +4 QUIT
- COMP(ORY) ;Get ADHOC sub components (FILE 142.1)
- +1 ;RPC => ORWRP2 HS COMPONENTS
- +2 ;Y(i)=(1)I;IFN^(2)Component Name [Abb]^(3)Occ Limit^(4)Time Limit^(5)Header Name^
- +3 ; (6)Hosp Loc Disp^(7)ICD Text Disp^(8)Prov Narr Disp^(9)Summary Order
- +4 DO COMP^GMTSADH5(.ORY)
- +5 QUIT
- +6 ;
- COMPABV(ORY) ;Get ADHOC sub components listed by Abbreviation
- +1 NEW I,X,X1,X2,X3
- +2 DO COMP^GMTSADH5(.ORY)
- +3 SET I=0
- +4 FOR
- SET I=$ORDER(ORY(I))
- if 'I
- QUIT
- SET X=ORY(I)
- Begin DoDot:1
- +5 SET X1=$PIECE($PIECE(X,"^",2),"[")
- SET X1=$EXTRACT(X1,1,$LENGTH(X1)-1)
- SET X2=$PIECE($PIECE(X,"^",2),"[",2)
- SET X2=$EXTRACT(X2,1,$LENGTH(X2)-1)
- +6 ;***
- if '$LENGTH(X2)
- SET X2="???"
- if '$LENGTH($PIECE(X,"^",5))
- SET $PIECE(X,"^",5)=$PIECE($PIECE(X,"^",2),"[")
- +7 SET X3=X2_" - "_$PIECE(X,"^",5)_" "
- SET $PIECE(ORY(I),"^",2)=X3
- End DoDot:1
- +8 QUIT
- COMPDISP(ORY) ;Get ADHOC sub components listed by Display Name
- +1 NEW I,X,X1,X2,X3
- +2 DO COMP^GMTSADH5(.ORY)
- +3 SET I=0
- +4 FOR
- SET I=$ORDER(ORY(I))
- if 'I
- QUIT
- SET X=ORY(I)
- Begin DoDot:1
- +5 SET X1=$PIECE($PIECE(X,"^",2),"[")
- SET X1=$EXTRACT(X1,1,$LENGTH(X1)-1)
- SET X2=$PIECE($PIECE(X,"^",2),"[",2)
- SET X2=$EXTRACT(X2,1,$LENGTH(X2)-1)
- +6 ;***
- if '$LENGTH(X2)
- SET X2="???"
- if '$LENGTH($PIECE(X,"^",5))
- SET $PIECE(X,"^",5)=$PIECE($PIECE(X,"^",2),"[")
- +7 SET X3=$PIECE(X,"^",5)_" ["_X2_"]"
- SET $PIECE(ORY(I),"^",2)=X3
- End DoDot:1
- +8 QUIT
- COMPSUB(ORY,ORSUB) ;Get subitems from a predefined Adhoc component
- +1 IF '$LENGTH($TEXT(COMPSUB^GMTSADH5))
- QUIT
- +2 DO COMPSUB^GMTSADH5(.ORY,ORSUB)
- +3 QUIT
- +4 ;
- SAVLKUP(OK,VAL) ;save Adhoc lookup selection
- +1 NEW ORERR
- +2 SET OK=""
- +3 DO EN^XPAR(DUZ_";VA(200,","ORWRP ADHOC LOOKUP",1,VAL,.ORERR)
- +4 IF ORERR
- SET OK=VAL_":"_ORERR
- +5 QUIT
- GETLKUP(ORY) ;Get Adhoc lookup selection
- +1 SET ORY=$$GET^XPAR("ALL","ORWRP ADHOC LOOKUP",1,"I")
- +2 QUIT
- FILES(ORY,ORCOMP) ;Get Files to select from for a component
- +1 ;RPC => ORWRP2 HS COMP FILES
- +2 DO FILES^GMTSADH5(.ORY,ORCOMP)
- +3 QUIT
- +4 ;
- FILESEL(OROOT,ORFILE,ORFROM,ORDIR) ;Get file entries for Combobox
- +1 ;RPC => ORWRP2 HS FILE LOOKUP
- +2 DO FILESEL^GMTSADH5(.OROOT,ORFILE,ORFROM,ORDIR)
- +3 QUIT
- +4 ;
- REPORT(OROOT,ORCOMPS,ORDFN) ;Build Report from array of Components passed in COMPS
- +1 ;RPC => ORWRP2 HS REPORT TEXT
- +2 ;ORCOMPS(i)=array of subcomponents chosen, value is pointer at ^GMT(142,DA(1),1,DA)
- +3 if '$GET(ORDFN)
- QUIT
- +4 NEW GMTSEGC,GMTSEG,ORGMTSEG,ORSEGC,ORSEGI
- +5 KILL ^TMP("ORDATA",$JOB)
- +6 DO REPORT^GMTSADH5(.ORGMTSEG,.ORSEGC,.ORSEGI,.ORCOMPS,.ORDFN)
- +7 if '$ORDER(ORGMTSEG(0))
- QUIT
- +8 DO START^ORWRP(80,"REPORT1^ORWRP2(.ORGMTSEG,.ORSEGC,.ORSEGI,ORDFN)")
- +9 SET OROOT=$NAME(^TMP("ORDATA",$JOB,1))
- +10 QUIT
- REPORT1(GMTSEG,GMTSEGC,GMTSEGI,DFN) ;
- +1 NEW GMTS,GMTS1,GMTS2,GMTSAGE,GMTSDOB,GMTSDTM,GMTSLO,GMTSLPG,GMTSPHDR,GMTSPNM,GMTSRB,GMTSSN,GMTSWRD
- +2 NEW CNT,INC,ORVP,ROOT,SEX,VADM,VAERR,VAIN
- +3 SET ORVP=DFN
- +4 DO ADHOC^ORPRS13
- +5 QUIT
- +6 ;
- SUBITEM(ORY,ORTEST) ;Get Subitems for a Test Panel
- +1 ;RPC => ORWRP2 HS SUBITEMS
- +2 DO SUBITEM^GMTSADH5(.ORY,ORTEST)
- +3 QUIT
- PREPORT(OROOT,ORCOMPS,ORDFN) ;Build Report & Print
- +1 ;Called from File|Print on Reports Tab after selecting ADHOC Health Summary
- +2 ;COMPS(i)=array of subcomponents chosen, value is pointer at ^GMT(142,DA(1),1,DA)
- +3 if '$GET(ORDFN)
- QUIT
- +4 NEW GMTSEGC,GMTSEG,ORGMTSEG,ORSEGC,ORSEGI
- +5 DO REPORT^GMTSADH5(.ORGMTSEG,.ORSEGC,.ORSEGI,.ORCOMPS,.ORDFN)
- +6 if '$ORDER(ORGMTSEG(0))
- QUIT
- +7 MERGE GMTSEG=ORGMTSEG,GMTSEGC=ORSEGC,GMTSEGI=ORSEGI
- +8 NEW GMTS,GMTS1,GMTS2,GMTSAGE,GMTSDOB,GMTSDTM,GMTSLO,GMTSLPG,GMTSPHDR,GMTSPNM,GMTSRB,GMTSSN,GMTSWRD
- +9 NEW CNT,INC,ORVP,ROOT,SEX,VADM,VAERR,VAIN
- +10 SET ORVP=ORDFN
- +11 DO ADHOC^ORPRS13
- +12 QUIT
- TRAN ;Get Transfused Units
- +1 NEW LRDFN,IDT,CNTR,TR,PN,PRODUCT,IX,GMI,X,BPN
- +2 if '$DATA(GMTS1)
- SET GMTS1=6666666
- if '$DATA(GMTS2)
- SET GMTS2=9999999
- +3 KILL ^TMP("LRT",$JOB)
- +4 if '$DATA(^DPT(DFN,"LR"))
- QUIT
- SET LRDFN=+^DPT(DFN,"LR")
- SET IDT=GMTS1-1
- +5 IF '$DATA(^LR(LRDFN))
- QUIT
- +6 SET IDT=0
- FOR
- SET IDT=$ORDER(^LR(LRDFN,1.6,IDT))
- if +IDT'>0
- QUIT
- Begin DoDot:1
- +7 SET TR=$GET(^LR(LRDFN,1.6,IDT,0))
- DO SET
- End DoDot:1
- +8 SET IDT=0
- FOR
- SET IDT=$ORDER(CNTR(IDT))
- if +IDT'>0
- QUIT
- Begin DoDot:1
- +9 SET ^TMP("LRT",$JOB,IDT)=9999999-IDT_U
- SET PN=0
- +10 FOR
- SET PN=$ORDER(CNTR(IDT,PN))
- if PN'>0
- QUIT
- Begin DoDot:2
- +11 SET PRODUCT=$GET(^LAB(66,+PN,0))
- SET ^TMP("LRT",$JOB,$PIECE(PRODUCT,U,2))=$PIECE(PRODUCT,U)
- +12 SET ^TMP("LRT",$JOB,IDT)=^TMP("LRT",$JOB,IDT)_CNTR(IDT,PN)_"\"_$PIECE(PRODUCT,U,2)_";"
- End DoDot:2
- End DoDot:1
- +13 if '$ORDER(^TMP("LRT",$JOB,0))
- QUIT
- +14 SET GCNT=+$ORDER(^TMP("LRC",$JOB,999999999),-1)
- +15 DO LINE
- DO LN
- +16 SET ^TMP("LRC",$JOB,GCNT,0)=$$S(0,CCNT,"Transfused Units")
- SET IX=""
- +17 FOR
- SET IX=$ORDER(^TMP("LRT",$JOB,IX))
- if IX=""
- QUIT
- Begin DoDot:1
- +18 SET GMR=^TMP("LRT",$JOB,IX)
- SET TD=$$FMTE^XLFDT(+GMR)
- +19 if TD=0
- QUIT
- +20 SET GMA(1)=$PIECE(GMR,U,2)
- SET BPN=$LENGTH(GMA(1),";")
- +21 IF $PIECE(GMA(1),";",BPN)=""
- SET BPN=BPN-1
- +22 FOR GMI=2:1:BPN
- SET GMA(GMI)="("_$PIECE($PIECE(GMA(1),";",GMI),"\")_") "_$PIECE($PIECE(GMA(1),";",GMI),"\",2)
- +23 SET GMA(1)="("_$PIECE($PIECE(GMA(1),";",1),"\")_") "_$PIECE($PIECE(GMA(1),";",1),"\",2)
- +24 DO WRT
- End DoDot:1
- +25 DO KEY
- +26 KILL ^TMP("LRT",$JOB)
- +27 QUIT
- WRT ; Writes the Transfusion Record for each day
- +1 NEW GML,GMI1,GMI2,GMM,GMJ,CL
- +2 SET GMM=$SELECT(BPN#4:1,1:0)
- SET GML=BPN\4+GMM
- +3 DO LN
- SET ^TMP("LRC",$JOB,GCNT,0)=$$S(2,.CCNT,TD)
- +4 FOR GMI1=1:1:GML
- Begin DoDot:1
- +5 FOR GMI2=1:1:($SELECT((GMI1=GML)&(BPN#4):BPN#4,1:4))
- Begin DoDot:2
- +6 SET GMJ=((GMI1-1)*4)+GMI2
- SET CL=(((GMI2-1)*15)+14)
- +7 SET ^TMP("LRC",$JOB,GCNT,0)=$GET(^TMP("LRC",$JOB,GCNT,0))_$$S(CL,.CCNT,GMA(GMJ))
- +8 IF $SELECT(GMI2#4=0:1,GMI2=BPN:1,GMI2+(4*(GMI1-1))=BPN:1,1:0)
- DO LN
- End DoDot:2
- End DoDot:1
- +9 QUIT
- SET ; Save Appropriate Data
- +1 NEW COMP,UNITS,TDT,ITDT
- +2 SET TDT=9999999-IDT
- SET ITDT=9999999-$PIECE(TDT,".")
- +3 SET UNITS=+$PIECE(TR,U,7)
- if UNITS'>0
- SET UNITS=1
- +4 SET CNTR(ITDT,+$PIECE(TR,U,2))=+$GET(CNTR(ITDT,+$PIECE(TR,U,2)))+UNITS
- +5 QUIT
- KEY ;
- +1 IF $ORDER(^TMP("LRT",$JOB,"A"))'=""
- Begin DoDot:1
- +2 DO LN
- +3 SET ^TMP("LRC",$JOB,GCNT,0)=$$S(0,CCNT," Blood Product Key: ")
- End DoDot:1
- +4 SET GMI="A"
- FOR
- SET GMI=$ORDER(^TMP("LRT",$JOB,GMI))
- if GMI=""
- QUIT
- Begin DoDot:1
- +5 SET ^TMP("LRC",$JOB,GCNT,0)=^TMP("LRC",$JOB,GCNT,0)_$$S(22,CCNT,GMI_" = "_$GET(^TMP("LRT",$JOB,GMI)))
- +6 DO LN
- +7 SET ^TMP("LRC",$JOB,GCNT,0)=""
- End DoDot:1
- +8 QUIT
- LN ;
- +1 SET GCNT=GCNT+1
- SET CCNT=1
- +2 QUIT
- LINE ;Fill in the global with bank lines
- +1 NEW X
- +2 DO LN
- +3 SET X=""
- SET $PIECE(X," ",GIOM)=""
- SET ^TMP("LRC",$JOB,GCNT,0)=X
- +4 QUIT
- S(X,Y,Z) ;Pad over
- +1 ;X=Column #
- +2 ;Y=Current length
- +3 ;Z=Text
- +4 ;SP=TEXT SENT
- +5 ;CCNT=Line position after input text
- +6 IF '$DATA(Z)
- QUIT ""
- +7 SET SP=Z
- IF X
- IF Y
- IF X>Y
- SET SP=$EXTRACT(" ",1,X-Y)_Z
- +8 SET CCNT=$$INC(CCNT,SP)
- +9 QUIT SP
- INC(X,Y) ;Character position count
- +1 ;X=Current count
- +2 ;Y=Text
- +3 SET INC=X+$LENGTH(Y)
- +4 QUIT INC