- ORWRPP ; ALB/MJK - Background Report Print Driver ;01/04/18 10:37
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,192,332,449,405**;Dec 17, 1997;Build 211
- ;
- ;
- PRINT(ORY,ORIO,ORDFN,ORRPTID,ORHSTYPE,ORDTRNG,OREXAMID,ORCOMP,ORALPHA,OROMEGA) ; -- print report entry point
- ; RPC: ORWRP PRINT REPORT
- ; See RPC definition for details on input and output parameters
- N ORHSTAG
- S ORHSTAG=$P($G(ORRPTID),"~",2),ORRPTID=$P($G(ORRPTID),"~"),ORRPTID=$P($P(ORRPTID,";"),":")
- IF '$$CHK() G PRINTQ
- N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,I,ZTIO
- S ZTIO=ORIO,ZTDTH=$H
- S ZTDESC="Report Print"
- S ZTRTN="DEQUE^ORWRPP"
- F I="ORDFN","ORRPTID","ORHSTYPE","ORDTRNG","OREXAMID","DUZ(","ORCOMP(","ORALPHA","OROMEGA","ORHSTAG" S ZTSAVE(I)=""
- D ^%ZTLOAD
- I $D(ZTSK) D
- . S ORY="0^Report queued. (Task #"_ZTSK_")"
- E D
- . S ORY="99^Task Rejected."
- PRINTQ Q
- REMOTE(ORY,ORIO,ORDFN,ORRPTID,ORHANDS) ;Print data for remote sites
- ; RPC: ORWRP PRINT REMOTE REPORT
- N ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,I,ORHSTAG,ZTIO
- S ORHSTAG=$P($G(ORRPTID),"~",2),ORRPTID=$P($G(ORRPTID),"~"),ORRPTID=$P($P(ORRPTID,";"),":")
- S ZTIO=ORIO,ZTDTH=$H
- S ZTDESC="Remote Report Print"
- S ZTRTN="DEQUE^ORWRPP"
- F I="ORDFN","ORRPTID","ORHANDS(","ORHSTAG" S ZTSAVE(I)=""
- D ^%ZTLOAD
- I $D(ZTSK) D
- . S ORY="0^Report queued. (Task #"_ZTSK_")"
- E D
- . S ORY="99^Task Rejected."
- Q
- PRINTW(ORTEXT,ORDFN,ORRPTID,ORHSTYPE,ORDTRNG,OREXAMID,ORCOMP,ORALPHA,OROMEGA) ;Windows device print
- N ZTQUEUED,ORHFS,ORSUB,ROOT,ORIO,ORHANDLE,ORWINDEV
- N IOM,IOSL,IOST,IOF,IOT,IOS,ORHSTAG,POP
- S ORHSTAG=$P($G(ORRPTID),"~",2),ORRPTID=$P($G(ORRPTID),"~"),ORRPTID=$P($P(ORRPTID,";"),":")
- S (ORSUB,ROOT)="ORDATA",ORIO="OR WINDOWS HFS",ORTEXT=$NA(^TMP(ORSUB,$J,1)),ORHANDLE="ORWRP"
- I '$$CHK() S @ORTEXT@(0)=ORY G PRINTWQ
- S ORHFS=$$HFS^ORWRP(),ORWINDEV=1 ;Flag for printing to windows device
- D HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W")
- I POP D Q
- . I $D(ROOT) D SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file")
- D IOVAR^ORWRP(.ORIO,,,"P-WINHFS80")
- N $ETRAP,$ESTACK
- S $ETRAP="D ERR^ORWRP Q"
- U IO
- D DEQUE
- D HFSCLOSE^ORWRP(ORHANDLE,ORHFS)
- PRINTWQ Q
- PRINTWR(ORTEXT,ORDFN,ORRPTID,ORHANDS) ;Windows Remote device print
- N ZTQUEUED,ORHFS,ORSUB,ROOT,ORIO,ORHANDLE,ORWINDEV
- N IOM,IOSL,IOST,IOF,IOT,IOS,ORHSTAG,POP
- S ORHSTAG=$P($G(ORRPTID),"~",2),ORRPTID=$P($G(ORRPTID),"~"),ORRPTID=$P($P(ORRPTID,";"),":")
- S (ORSUB,ROOT)="ORDATA",ORIO="OR WINDOWS HFS",ORTEXT=$NA(^TMP(ORSUB,$J,1)),ORHANDLE="ORWRP"
- S ORHFS=$$HFS^ORWRP(),ORWINDEV=1 ;Flag for printing to windows device
- D HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W")
- I POP D Q
- . I $D(ROOT) D SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file")
- D IOVAR^ORWRP(.ORIO,,,"P-WINHFS80")
- N $ETRAP,$ESTACK
- S $ETRAP="D ERR^ORWRP Q"
- U IO
- D DEQUE
- D HFSCLOSE^ORWRP(ORHANDLE,ORHFS)
- Q
- CHK() ; -- do checks for required data
- N OROK,FALSE,TRUE,ORRPT,TXT,I,J,REPORT
- S FALSE=0,TRUE=1,I="",REPORT=""
- IF $G(ORIO)']"" S OROK=FALSE,ORY="1^No device selected." G CHKQ
- IF '$L($G(ORRPTID)) S OROK=FALSE,ORY="2^No report specified." G CHKQ
- ; -- get report definition
- F S I=$O(^ORD(101.24,"AC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.24,"AC",I,J)) Q:'J D
- . I $P($G(^ORD(101.24,J,0)),"^",2)=ORRPTID,$P(^(0),"^",8)="R" S REPORT=^(0)
- I '$L(REPORT) S OROK=FALSE,ORY="2^Report not available." G CHKQ
- S (TXT,ORRPT)=""
- IF $P(REPORT,U,7)=1!($P(REPORT,U,7)=3),'$L($G(ORDTRNG)),'$G(ORALPHA) S OROK=FALSE,ORY="4^No date range specified." G CHKQ
- IF $P(REPORT,U,4)=1,$G(ORHSTYPE)=0,'$O(ORCOMP(0)) S OROK=FALSE,ORY="10^No Adhoc components specified." G CHKQ
- IF $P(REPORT,U,4)=1,'$G(ORHSTYPE),$P($G(ORHSTYPE),":")'=0 S OROK=FALSE,ORY="5^No health summary type specified." G CHKQ
- IF $P(REPORT,U,4)=3,'$G(OREXAMID) S OROK=FALSE,ORY="7^No exam identified" G CHKQ
- IF $P(REPORT,U,4)=4,'$L($G(OREXAMID)) S OROK=FALSE,ORY="9^No assessment identified" G CHKQ
- IF $P(REPORT,U,4)=19,'$L($G(OREXAMID)) S OROK=FALSE,ORY="8^No procedure date identified" G CHKQ
- IF '$D(^DPT(+$G(ORDFN),0)) S OROK=FALSE,ORY="6^Patient specified is not valid." G CHKQ
- S OROK=TRUE
- CHKQ Q OROK
- ;
- DEQUE ; -- logic to print queued report
- ; -- call build report logic
- N I,J,X0,X1,X2,X4,SITE,RTN,ENT,ID,ORID,ORHEADER,ORI,ORX,ORVP,OUT,PENT,POUT,PRTN,ROOT,MAX,ORPRTING
- S ORVP=ORDFN_";DPT(",ROOT="ORDATA",POUT="",ORPRTING=1
- S I=0,(X1,X2,ORID,REPORT)="",SITE=$$SITE^VASITE,SITE=$P(SITE,"^",2)_";"_$P(SITE,"^",3)
- F S I=$O(^ORD(101.24,"AC",I)) Q:I="" S J=0 F S J=$O(^ORD(101.24,"AC",I,J)) Q:'J D
- . I $P($G(^ORD(101.24,J,0)),"^",2)=ORRPTID,$P(^(0),"^",8)="R" S X0=^(0),X2=$G(^(2)),ORID=$P(X2,"^",3),ORFHIE=$G(^(4)),X4=$P(ORFHIE,"^",2),ORFHIE=$P(ORFHIE,"^",3)
- I '$L(X0) D NOTYET(.ROOT) Q
- S RTN=$P(X0,"^",5),ENT=$P(X0,"^",6)
- I '$L(RTN)!'$L(ENT) D NOTYET(.ROOT) Q
- I '$L($T(@(ENT_"^"_RTN))) D NOTYET(.ROOT) Q
- S PRTN=$P(X2,"^",7),PENT=$P(X2,"^",6)
- I $G(ORALPHA) S X=$$FMDIFF^XLFDT(ORALPHA,$G(OROMEGA)) D
- . I X<0 S X=X*(-1)
- . I X4,X>X4 S:ORALPHA>OROMEGA OROMEGA=$$FMADD^XLFDT(ORALPHA,-X4) S:ORALPHA'>OROMEGA ORALPHA=$$FMADD^XLFDT(OROMEGA,-X4) S ORDTRNG=""
- I X4,$G(ORDTRNG)>X4 S ORDTRNG=X4,ORALPHA=""
- I $L($G(ORDTRNG)),'$G(ORALPHA) S ORALPHA=$$FMADD^XLFDT(DT,-ORDTRNG),OROMEGA=DT_".235959"
- I $G(OROMEGA),$E(OROMEGA,8)'="." S OROMEGA=OROMEGA_".235959"
- S ID=$G(ORHSTAG),$P(ID,";",5,8)=SITE_";"_$P(X2,"^",8)_";"_$P(X2,"^",9)
- I $L($P($G(ORHSTAG),";",4)) S MAX=$P(ORHSTAG,";",4)
- I $L($G(ORHSTYPE)) M ID=ORHSTYPE
- I $L($G(OREXAMID)) M ID=OREXAMID
- I $L(PRTN),$L(PENT),$L($T(@(PENT_"^"_PRTN))) S POUT=PENT_"^"_PRTN_"(.ROOT,ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.MAX,.ORFHIE)"
- S OUT=ENT_"^"_RTN_"(.ROOT,ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.MAX,.ORFHIE)"
- I '$O(ORHANDS(0)) D G OUT
- . N ORY,PAGE
- . I $L(POUT) D @POUT Q ;Go to non-standard print routine
- . D @OUT
- . Q:'$L(ROOT)
- . S PAGE=1
- . D HEAD^ORWRPP1(ORDFN,PAGE,ORID,$G(STATION))
- . D HURL^ORWRPP1(.ROOT,ORDFN,ORID)
- S ORI=0
- F S ORI=$O(ORHANDS(ORI)) Q:'ORI S ORX=ORHANDS(ORI) D
- . N ORY,PAGE,ORALPHA,OROMEGA
- . D RTNDATA^XWBDRPC(.ORY,$P(ORX,"^",2))
- . S:ORY="" ORY="ORY"
- . S PAGE=1,ORALPHA=$P(ORX,"^",3),OROMEGA=$P(ORX,"^",4)
- . D HEAD^ORWRPP1(ORDFN,PAGE,ORID,$P(ORX,"^"))
- . D HURL^ORWRPP1(.ORY,ORDFN,ORID,1,$P(ORX,"^"))
- OUT I $L($G(ROOT)) K @ROOT
- Q
- SITE(ORSTA) ;Print Station info
- N X
- I $G(ORSTA) S ORSTA=$$IEN^XUAF4(ORSTA)
- S:'$L($G(ORSTA)) ORSTA=$G(DUZ(2))
- S X="Report from: "_$$GET1^DIQ(4,+ORSTA,.01,"E")_" Station #"_$$GET1^DIQ(4,+ORSTA,99,"E")
- W !?(IOM/2-($L(X)/2)),X
- Q
- LRSITE(ORSTA) ;Print Station info
- N X,ORADD
- I $G(ORSTA) S ORSTA=$$IEN^XUAF4(ORSTA)
- S:'$L($G(ORSTA)) ORSTA=$G(DUZ(2))
- S X="Report from: "_$$GET1^DIQ(4,+ORSTA,.01,"E")_" Station #"_$$GET1^DIQ(4,+ORSTA,99,"E")
- W !?(IOM/2-($L(X)/2)),X
- S ORADD=$$PADD^XUAF4(+ORSTA)
- S ORADD=$P(ORADD,"^")_", "_$P(ORADD,"^",2)_", "_$P(ORADD,"^",3)_" "_$P(ORADD,"^",4)
- S ORADD=$E(ORADD,1,76)
- W !?(IOM/2-($L(ORADD)/2)),ORADD
- Q
- NOTYET(ROOT) ; -- standard not available display text
- D SETITEM(.ROOT,"Report not available at this time.")
- Q
- SETITEM(ROOT,X) ; -- set item in list
- S @ROOT@($O(@ROOT@(9999),-1)+1)=X
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWRPP 7144 printed Feb 19, 2025@00:03:58 Page 2
- ORWRPP ; ALB/MJK - Background Report Print Driver ;01/04/18 10:37
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,192,332,449,405**;Dec 17, 1997;Build 211
- +2 ;
- +3 ;
- PRINT(ORY,ORIO,ORDFN,ORRPTID,ORHSTYPE,ORDTRNG,OREXAMID,ORCOMP,ORALPHA,OROMEGA) ; -- print report entry point
- +1 ; RPC: ORWRP PRINT REPORT
- +2 ; See RPC definition for details on input and output parameters
- +3 NEW ORHSTAG
- +4 SET ORHSTAG=$PIECE($GET(ORRPTID),"~",2)
- SET ORRPTID=$PIECE($GET(ORRPTID),"~")
- SET ORRPTID=$PIECE($PIECE(ORRPTID,";"),":")
- +5 IF '$$CHK()
- GOTO PRINTQ
- +6 NEW ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,I,ZTIO
- +7 SET ZTIO=ORIO
- SET ZTDTH=$HOROLOG
- +8 SET ZTDESC="Report Print"
- +9 SET ZTRTN="DEQUE^ORWRPP"
- +10 FOR I="ORDFN","ORRPTID","ORHSTYPE","ORDTRNG","OREXAMID","DUZ(","ORCOMP(","ORALPHA","OROMEGA","ORHSTAG"
- SET ZTSAVE(I)=""
- +11 DO ^%ZTLOAD
- +12 IF $DATA(ZTSK)
- Begin DoDot:1
- +13 SET ORY="0^Report queued. (Task #"_ZTSK_")"
- End DoDot:1
- +14 IF '$TEST
- Begin DoDot:1
- +15 SET ORY="99^Task Rejected."
- End DoDot:1
- PRINTQ QUIT
- REMOTE(ORY,ORIO,ORDFN,ORRPTID,ORHANDS) ;Print data for remote sites
- +1 ; RPC: ORWRP PRINT REMOTE REPORT
- +2 NEW ZTDTH,ZTRTN,ZTSK,ZTDESC,ZTSAVE,I,ORHSTAG,ZTIO
- +3 SET ORHSTAG=$PIECE($GET(ORRPTID),"~",2)
- SET ORRPTID=$PIECE($GET(ORRPTID),"~")
- SET ORRPTID=$PIECE($PIECE(ORRPTID,";"),":")
- +4 SET ZTIO=ORIO
- SET ZTDTH=$HOROLOG
- +5 SET ZTDESC="Remote Report Print"
- +6 SET ZTRTN="DEQUE^ORWRPP"
- +7 FOR I="ORDFN","ORRPTID","ORHANDS(","ORHSTAG"
- SET ZTSAVE(I)=""
- +8 DO ^%ZTLOAD
- +9 IF $DATA(ZTSK)
- Begin DoDot:1
- +10 SET ORY="0^Report queued. (Task #"_ZTSK_")"
- End DoDot:1
- +11 IF '$TEST
- Begin DoDot:1
- +12 SET ORY="99^Task Rejected."
- End DoDot:1
- +13 QUIT
- PRINTW(ORTEXT,ORDFN,ORRPTID,ORHSTYPE,ORDTRNG,OREXAMID,ORCOMP,ORALPHA,OROMEGA) ;Windows device print
- +1 NEW ZTQUEUED,ORHFS,ORSUB,ROOT,ORIO,ORHANDLE,ORWINDEV
- +2 NEW IOM,IOSL,IOST,IOF,IOT,IOS,ORHSTAG,POP
- +3 SET ORHSTAG=$PIECE($GET(ORRPTID),"~",2)
- SET ORRPTID=$PIECE($GET(ORRPTID),"~")
- SET ORRPTID=$PIECE($PIECE(ORRPTID,";"),":")
- +4 SET (ORSUB,ROOT)="ORDATA"
- SET ORIO="OR WINDOWS HFS"
- SET ORTEXT=$NAME(^TMP(ORSUB,$JOB,1))
- SET ORHANDLE="ORWRP"
- +5 IF '$$CHK()
- SET @ORTEXT@(0)=ORY
- GOTO PRINTWQ
- +6 ;Flag for printing to windows device
- SET ORHFS=$$HFS^ORWRP()
- SET ORWINDEV=1
- +7 DO HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W")
- +8 IF POP
- Begin DoDot:1
- +9 IF $DATA(ROOT)
- DO SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file")
- End DoDot:1
- QUIT
- +10 DO IOVAR^ORWRP(.ORIO,,,"P-WINHFS80")
- +11 NEW $ETRAP,$ESTACK
- +12 SET $ETRAP="D ERR^ORWRP Q"
- +13 USE IO
- +14 DO DEQUE
- +15 DO HFSCLOSE^ORWRP(ORHANDLE,ORHFS)
- PRINTWQ QUIT
- PRINTWR(ORTEXT,ORDFN,ORRPTID,ORHANDS) ;Windows Remote device print
- +1 NEW ZTQUEUED,ORHFS,ORSUB,ROOT,ORIO,ORHANDLE,ORWINDEV
- +2 NEW IOM,IOSL,IOST,IOF,IOT,IOS,ORHSTAG,POP
- +3 SET ORHSTAG=$PIECE($GET(ORRPTID),"~",2)
- SET ORRPTID=$PIECE($GET(ORRPTID),"~")
- SET ORRPTID=$PIECE($PIECE(ORRPTID,";"),":")
- +4 SET (ORSUB,ROOT)="ORDATA"
- SET ORIO="OR WINDOWS HFS"
- SET ORTEXT=$NAME(^TMP(ORSUB,$JOB,1))
- SET ORHANDLE="ORWRP"
- +5 ;Flag for printing to windows device
- SET ORHFS=$$HFS^ORWRP()
- SET ORWINDEV=1
- +6 DO HFSOPEN^ORWRP(ORHANDLE,ORHFS,"W")
- +7 IF POP
- Begin DoDot:1
- +8 IF $DATA(ROOT)
- DO SETITEM^ORWRP(.ROOT,"ERROR: Unable to open HFS file")
- End DoDot:1
- QUIT
- +9 DO IOVAR^ORWRP(.ORIO,,,"P-WINHFS80")
- +10 NEW $ETRAP,$ESTACK
- +11 SET $ETRAP="D ERR^ORWRP Q"
- +12 USE IO
- +13 DO DEQUE
- +14 DO HFSCLOSE^ORWRP(ORHANDLE,ORHFS)
- +15 QUIT
- CHK() ; -- do checks for required data
- +1 NEW OROK,FALSE,TRUE,ORRPT,TXT,I,J,REPORT
- +2 SET FALSE=0
- SET TRUE=1
- SET I=""
- SET REPORT=""
- +3 IF $GET(ORIO)']""
- SET OROK=FALSE
- SET ORY="1^No device selected."
- GOTO CHKQ
- +4 IF '$LENGTH($GET(ORRPTID))
- SET OROK=FALSE
- SET ORY="2^No report specified."
- GOTO CHKQ
- +5 ; -- get report definition
- +6 FOR
- SET I=$ORDER(^ORD(101.24,"AC",I))
- if I=""
- QUIT
- SET J=0
- FOR
- SET J=$ORDER(^ORD(101.24,"AC",I,J))
- if 'J
- QUIT
- Begin DoDot:1
- +7 IF $PIECE($GET(^ORD(101.24,J,0)),"^",2)=ORRPTID
- IF $PIECE(^(0),"^",8)="R"
- SET REPORT=^(0)
- End DoDot:1
- +8 IF '$LENGTH(REPORT)
- SET OROK=FALSE
- SET ORY="2^Report not available."
- GOTO CHKQ
- +9 SET (TXT,ORRPT)=""
- +10 IF $PIECE(REPORT,U,7)=1!($PIECE(REPORT,U,7)=3)
- IF '$LENGTH($GET(ORDTRNG))
- IF '$GET(ORALPHA)
- SET OROK=FALSE
- SET ORY="4^No date range specified."
- GOTO CHKQ
- +11 IF $PIECE(REPORT,U,4)=1
- IF $GET(ORHSTYPE)=0
- IF '$ORDER(ORCOMP(0))
- SET OROK=FALSE
- SET ORY="10^No Adhoc components specified."
- GOTO CHKQ
- +12 IF $PIECE(REPORT,U,4)=1
- IF '$GET(ORHSTYPE)
- IF $PIECE($GET(ORHSTYPE),":")'=0
- SET OROK=FALSE
- SET ORY="5^No health summary type specified."
- GOTO CHKQ
- +13 IF $PIECE(REPORT,U,4)=3
- IF '$GET(OREXAMID)
- SET OROK=FALSE
- SET ORY="7^No exam identified"
- GOTO CHKQ
- +14 IF $PIECE(REPORT,U,4)=4
- IF '$LENGTH($GET(OREXAMID))
- SET OROK=FALSE
- SET ORY="9^No assessment identified"
- GOTO CHKQ
- +15 IF $PIECE(REPORT,U,4)=19
- IF '$LENGTH($GET(OREXAMID))
- SET OROK=FALSE
- SET ORY="8^No procedure date identified"
- GOTO CHKQ
- +16 IF '$DATA(^DPT(+$GET(ORDFN),0))
- SET OROK=FALSE
- SET ORY="6^Patient specified is not valid."
- GOTO CHKQ
- +17 SET OROK=TRUE
- CHKQ QUIT OROK
- +1 ;
- DEQUE ; -- logic to print queued report
- +1 ; -- call build report logic
- +2 NEW I,J,X0,X1,X2,X4,SITE,RTN,ENT,ID,ORID,ORHEADER,ORI,ORX,ORVP,OUT,PENT,POUT,PRTN,ROOT,MAX,ORPRTING
- +3 SET ORVP=ORDFN_";DPT("
- SET ROOT="ORDATA"
- SET POUT=""
- SET ORPRTING=1
- +4 SET I=0
- SET (X1,X2,ORID,REPORT)=""
- SET SITE=$$SITE^VASITE
- SET SITE=$PIECE(SITE,"^",2)_";"_$PIECE(SITE,"^",3)
- +5 FOR
- SET I=$ORDER(^ORD(101.24,"AC",I))
- if I=""
- QUIT
- SET J=0
- FOR
- SET J=$ORDER(^ORD(101.24,"AC",I,J))
- if 'J
- QUIT
- Begin DoDot:1
- +6 IF $PIECE($GET(^ORD(101.24,J,0)),"^",2)=ORRPTID
- IF $PIECE(^(0),"^",8)="R"
- SET X0=^(0)
- SET X2=$GET(^(2))
- SET ORID=$PIECE(X2,"^",3)
- SET ORFHIE=$GET(^(4))
- SET X4=$PIECE(ORFHIE,"^",2)
- SET ORFHIE=$PIECE(ORFHIE,"^",3)
- End DoDot:1
- +7 IF '$LENGTH(X0)
- DO NOTYET(.ROOT)
- QUIT
- +8 SET RTN=$PIECE(X0,"^",5)
- SET ENT=$PIECE(X0,"^",6)
- +9 IF '$LENGTH(RTN)!'$LENGTH(ENT)
- DO NOTYET(.ROOT)
- QUIT
- +10 IF '$LENGTH($TEXT(@(ENT_"^"_RTN)))
- DO NOTYET(.ROOT)
- QUIT
- +11 SET PRTN=$PIECE(X2,"^",7)
- SET PENT=$PIECE(X2,"^",6)
- +12 IF $GET(ORALPHA)
- SET X=$$FMDIFF^XLFDT(ORALPHA,$GET(OROMEGA))
- Begin DoDot:1
- +13 IF X<0
- SET X=X*(-1)
- +14 IF X4
- IF X>X4
- if ORALPHA>OROMEGA
- SET OROMEGA=$$FMADD^XLFDT(ORALPHA,-X4)
- if ORALPHA'>OROMEGA
- SET ORALPHA=$$FMADD^XLFDT(OROMEGA,-X4)
- SET ORDTRNG=""
- End DoDot:1
- +15 IF X4
- IF $GET(ORDTRNG)>X4
- SET ORDTRNG=X4
- SET ORALPHA=""
- +16 IF $LENGTH($GET(ORDTRNG))
- IF '$GET(ORALPHA)
- SET ORALPHA=$$FMADD^XLFDT(DT,-ORDTRNG)
- SET OROMEGA=DT_".235959"
- +17 IF $GET(OROMEGA)
- IF $EXTRACT(OROMEGA,8)'="."
- SET OROMEGA=OROMEGA_".235959"
- +18 SET ID=$GET(ORHSTAG)
- SET $PIECE(ID,";",5,8)=SITE_";"_$PIECE(X2,"^",8)_";"_$PIECE(X2,"^",9)
- +19 IF $LENGTH($PIECE($GET(ORHSTAG),";",4))
- SET MAX=$PIECE(ORHSTAG,";",4)
- +20 IF $LENGTH($GET(ORHSTYPE))
- MERGE ID=ORHSTYPE
- +21 IF $LENGTH($GET(OREXAMID))
- MERGE ID=OREXAMID
- +22 IF $LENGTH(PRTN)
- IF $LENGTH(PENT)
- IF $LENGTH($TEXT(@(PENT_"^"_PRTN)))
- SET POUT=PENT_"^"_PRTN_"(.ROOT,ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.MAX,.ORFHIE)"
- +23 SET OUT=ENT_"^"_RTN_"(.ROOT,ORDFN,.ID,.ORALPHA,.OROMEGA,.ORDTRNG,.REMOTE,.MAX,.ORFHIE)"
- +24 IF '$ORDER(ORHANDS(0))
- Begin DoDot:1
- +25 NEW ORY,PAGE
- +26 ;Go to non-standard print routine
- IF $LENGTH(POUT)
- DO @POUT
- QUIT
- +27 DO @OUT
- +28 if '$LENGTH(ROOT)
- QUIT
- +29 SET PAGE=1
- +30 DO HEAD^ORWRPP1(ORDFN,PAGE,ORID,$GET(STATION))
- +31 DO HURL^ORWRPP1(.ROOT,ORDFN,ORID)
- End DoDot:1
- GOTO OUT
- +32 SET ORI=0
- +33 FOR
- SET ORI=$ORDER(ORHANDS(ORI))
- if 'ORI
- QUIT
- SET ORX=ORHANDS(ORI)
- Begin DoDot:1
- +34 NEW ORY,PAGE,ORALPHA,OROMEGA
- +35 DO RTNDATA^XWBDRPC(.ORY,$PIECE(ORX,"^",2))
- +36 if ORY=""
- SET ORY="ORY"
- +37 SET PAGE=1
- SET ORALPHA=$PIECE(ORX,"^",3)
- SET OROMEGA=$PIECE(ORX,"^",4)
- +38 DO HEAD^ORWRPP1(ORDFN,PAGE,ORID,$PIECE(ORX,"^"))
- +39 DO HURL^ORWRPP1(.ORY,ORDFN,ORID,1,$PIECE(ORX,"^"))
- End DoDot:1
- OUT IF $LENGTH($GET(ROOT))
- KILL @ROOT
- +1 QUIT
- SITE(ORSTA) ;Print Station info
- +1 NEW X
- +2 IF $GET(ORSTA)
- SET ORSTA=$$IEN^XUAF4(ORSTA)
- +3 if '$LENGTH($GET(ORSTA))
- SET ORSTA=$GET(DUZ(2))
- +4 SET X="Report from: "_$$GET1^DIQ(4,+ORSTA,.01,"E")_" Station #"_$$GET1^DIQ(4,+ORSTA,99,"E")
- +5 WRITE !?(IOM/2-($LENGTH(X)/2)),X
- +6 QUIT
- LRSITE(ORSTA) ;Print Station info
- +1 NEW X,ORADD
- +2 IF $GET(ORSTA)
- SET ORSTA=$$IEN^XUAF4(ORSTA)
- +3 if '$LENGTH($GET(ORSTA))
- SET ORSTA=$GET(DUZ(2))
- +4 SET X="Report from: "_$$GET1^DIQ(4,+ORSTA,.01,"E")_" Station #"_$$GET1^DIQ(4,+ORSTA,99,"E")
- +5 WRITE !?(IOM/2-($LENGTH(X)/2)),X
- +6 SET ORADD=$$PADD^XUAF4(+ORSTA)
- +7 SET ORADD=$PIECE(ORADD,"^")_", "_$PIECE(ORADD,"^",2)_", "_$PIECE(ORADD,"^",3)_" "_$PIECE(ORADD,"^",4)
- +8 SET ORADD=$EXTRACT(ORADD,1,76)
- +9 WRITE !?(IOM/2-($LENGTH(ORADD)/2)),ORADD
- +10 QUIT
- NOTYET(ROOT) ; -- standard not available display text
- +1 DO SETITEM(.ROOT,"Report not available at this time.")
- +2 QUIT
- SETITEM(ROOT,X) ; -- set item in list
- +1 SET @ROOT@($ORDER(@ROOT@(9999),-1)+1)=X
- +2 QUIT