- RARTE2 ;HISC/SWM-Edit/Delete a Report ;7/16/01 14:05
- ;;5.0;Radiology/Nuclear Medicine;**10,31,47**;Mar 16, 1998;Build 21
- ; known vars-->RADFN,RACNI,RADTI,RARPT,RARPTN
- PTR ; if current ^RADPT() rec is a PRINT SET,
- ; then for other ^RADPT() recs of the same PRINT SET,
- ; create its corresponding subrec in ^RARPT()
- S RAXIT=0
- I '$D(RADFN)!'$D(RACNI)!'$D(RADTI)!'$D(RARPT)!'$D(RARPTN) D Q
- . S RAXIT=1 Q:$G(RARIC)
- . I '$D(RAQUIET) W !!,$C(7),"Missing data (routine RARTE2)",! S RAOUT=$$EOS^RAUTL5() Q
- . S RAERR="Missing data needed by routine RARTE2"
- . Q
- N RA1,RA2,RA3,RAFDA,RAIEN,RAMSG ;RA3=exam status
- S RA1=0
- PTR2 S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P","B",RA1)) Q:RA1="" S RA2=$O(^(RA1,0)),RA3=$P(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),"^",3) G:$P(^(0),"^",25)'=2 PTR2 ;skip non-combined rpt
- G:RA2=RACNI PTR2 ;skip already processed case
- K RAFDA,RAIEN,RAMSG
- ASK G:$G(RARIC) UPD G:$D(RAQUIET) UPD ; don't ask, if from Img pkg or Kurzweil
- I $P(^RA(72,+RA3,0),"^",3)=0 D G:%=2 PTR2 G:%'=1 ASK
- . W !!,"Case ",RA1," of this print set has been cancelled."
- . W !,"Do you want to include it in the report anyway"
- . S %=2 D YN^DICN
- . W:%>0 "...",$S(%=2:"Ex",%=1:"In",1:""),"clude case ",RA1
- . Q
- ; update file #70, field REPORT TEXT
- UPD S $P(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),U,17)=RARPT
- D INSERT
- Q:RAXIT G PTR2
- INSERT ; add subrec to file #74's subfile #74.05
- ; P47 - if SSAN in use set OTHER CASES in Printset to SSAN format
- I $L(RARPTN,"-")>2 S RAFDA(74.05,"?+2,"_RARPT_",",.01)=$P(RARPTN,"-",1,2)_"-"_RA1
- I $L(RARPTN,"-")<3 S RAFDA(74.05,"?+2,"_RARPT_",",.01)=$P(RARPTN,"-")_"-"_RA1
- D UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
- I $D(RAMSG) D Q
- . S RAXIT=1 Q:$G(RARIC)
- . I '$D(RAQUIET) W !!,$C(7),"Error encountered while setting sub-records (routine RARTE2)",! S RAOUT=$$EOS^RAUTL5() Q ;error detected
- . S RAERR="Error encountered while setting sub-recs from RARTE2"
- Q
- DEL17(RAIEN) ;del other print set members' pointer to #74
- Q:'$D(RADFN)!('$D(RADTI))
- N RA4,RA1 D EN3^RAUTL20(.RA4)
- Q:'$O(RA4(0))
- S RA1=""
- D18 S RA1=$O(RA4(RA1)) Q:RA1=""
- ; kill xrefs, if any, for file #70's REPORT TEXT
- S DA(2)=RADFN,DA(1)=RADTI,DA=RA1
- ; if this exam's piece 17 doesn't match RAIEN, then don't remove pc17
- I $P($G(^RADPT(RADFN,"DT",RADTI,"P",RA1,0)),"^",17)'=RAIEN G D18
- D ENKILL^RAXREF(70.03,17,RAIEN,.DA)
- ; set REPORT TEXT to null
- S:$D(^RADPT(RADFN,"DT",RADTI,"P",RA1,0)) $P(^(0),"^",17)=""
- G D18
- COPY ;copy physicians and diagnoses
- Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))!('$D(RAMEMARR))!('$D(RADRS))
- W !!,"... now copying ",$S(RADRS=1:"Diagnostic Codes",1:"Staff & Resident data")," to other cases in this print set ...",!
- N RA1,RA2,RA3
- N RA1PR,RA1PS ;prim res/staff
- N RA1SR,RA1SS ; sec res/staff arrays--(ien subfile #70.11)=ien file #200
- N RA1PD,RA1SD ; prim diag, then sec diags array
- N RAFDA,RAIEN,RAMSG
- ;prim res, prim staff, prim diag
- S RA1=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) S:RADRS=2 RA1PR=$P(RA1,"^",12),RA1PS=$P(RA1,"^",15) S:RADRS=1 RA1PD=$P(RA1,"^",13)
- ;sec residents
- I RADRS=2,$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RA1)) Q:+RA1'=RA1 S RA1SR(RA1)=+^(RA1,0)
- ;sec staff
- I RADRS=2,$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RA1)) Q:+RA1'=RA1 S RA1SS(RA1)=+^(RA1,0)
- ;sec diagnoses
- I RADRS=1,$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0)) S RA1=0 F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RA1)) Q:+RA1'=RA1 S RA1SD(RA1)=+^(RA1,0)
- ;loop thru other cases of this printset
- S RA1=0
- COPYLOOP S RA1=$O(RAMEMARR(RA1)) G:RA1="" COPYREF G:RA1=RACNI COPYLOOP ;skip what's done already
- ;
- ; copy primary staff and resident via Fileman
- I RADRS=2 D
- . S DA(2)=RADFN,DA(1)=RADTI,DA=RA1
- . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
- . S DR="12////"_RA1PR_";15////"_RA1PS
- . D ^DIE K DA,DIE,DR ; no locking
- . Q
- ;
- ; copy primary diagnostic code via Fileman
- I RADRS=1 D
- . S DA(2)=RADFN,DA(1)=RADTI,DA=RA1
- . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
- . S DR="13////"_RA1PD
- . D ^DIE K DA,DIE,DR ; no locking
- . Q
- ;
- S RA2=RA1_","_RADTI_","_RADFN ;stem for dataserver call
- S DA(3)=RADFN,DA(2)=RADTI,DA(1)=RA1 ;base vars for DIK call
- I RADRS=2 S RA3=0 D KIL3 G:RAXIT Q ; sec res
- I RADRS=2 S RA3=0 D KIL4 G:RAXIT Q ; sec staff
- I RADRS=1 S RA3=0 D KIL5 G:RAXIT Q ; sec diag
- G COPYLOOP
- KIL3 S RA3=$O(^RADPT(RADFN,"DT",RADTI,"P",RA1,"SRR",RA3)) G:RA3="" COPY3
- S DA=RA3
- S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""SRR"","
- D ^DIK
- G KIL3
- COPY3 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SR(RA3)) Q:'RA3 Q:RAXIT
- UP3 ;
- S RAFDA(70.09,"?+2,"_RA2_",",.01)=RA1SR(RA3)
- D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") G:'$D(RAMSG) COPY3
- S RAXIT=1 W !!,$C(7),"Error encountered while in adding rec ",RA3," to sub-file 70.09" Q
- KIL4 S RA3=$O(^RADPT(RADFN,"DT",RADTI,"P",RA1,"SSR",RA3)) G:RA3="" COPY4
- S DA=RA3
- S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""SSR"","
- D ^DIK
- G KIL4
- COPY4 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SS(RA3)) Q:'RA3 Q:RAXIT
- UP4 ;
- S RAFDA(70.11,"?+2,"_RA2_",",.01)=RA1SS(RA3)
- D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") G:'$D(RAMSG) COPY4
- S RAXIT=1 W !!,$C(7),"Error encountered while in adding rec ",RA3," to sub-file 70.11" Q
- KIL5 S RA3=$O(^RADPT(RADFN,"DT",RADTI,"P",RA1,"DX",RA3)) G:RA3="" COPY5
- S DA=RA3
- S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""DX"","
- D ^DIK
- G KIL5
- COPY5 K RAFDA,RAIEN,RAMSG S RA3=$O(RA1SD(RA3)) Q:'RA3 Q:RAXIT
- UP5 ;
- S RAFDA(70.14,"?+2,"_RA2_",",.01)=RA1SD(RA3)
- D UPDATE^DIE("","RAFDA","RAIEN","RAMSG") G:'$D(RAMSG) COPY5
- S RAXIT=1 W !!,$C(7),"Error encountered while in adding rec ",RA3," to sub-file 70.14" Q
- COPYREF ; clear out Fileman vars and quit
- K DA,DIK
- Q ; don't need to re-xref again
- Q K DA Q
- RARTE2 ;HISC/SWM-Edit/Delete a Report ;7/16/01 14:05
- +1 ;;5.0;Radiology/Nuclear Medicine;**10,31,47**;Mar 16, 1998;Build 21
- +2 ; known vars-->RADFN,RACNI,RADTI,RARPT,RARPTN
- PTR ; if current ^RADPT() rec is a PRINT SET,
- +1 ; then for other ^RADPT() recs of the same PRINT SET,
- +2 ; create its corresponding subrec in ^RARPT()
- +3 SET RAXIT=0
- +4 IF '$DATA(RADFN)!'$DATA(RACNI)!'$DATA(RADTI)!'$DATA(RARPT)!'$DATA(RARPTN)
- Begin DoDot:1
- +5 SET RAXIT=1
- IF $GET(RARIC)
- QUIT
- +6 IF '$DATA(RAQUIET)
- WRITE !!,$CHAR(7),"Missing data (routine RARTE2)",!
- SET RAOUT=$$EOS^RAUTL5()
- QUIT
- +7 SET RAERR="Missing data needed by routine RARTE2"
- +8 QUIT
- End DoDot:1
- QUIT
- +9 ;RA3=exam status
- NEW RA1,RA2,RA3,RAFDA,RAIEN,RAMSG
- +10 SET RA1=0
- PTR2 ;skip non-combined rpt
- SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",RA1))
- IF RA1=""
- QUIT
- SET RA2=$ORDER(^(RA1,0))
- SET RA3=$PIECE(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),"^",3)
- IF $PIECE(^(0),"^",25)'=2
- GOTO PTR2
- +1 ;skip already processed case
- IF RA2=RACNI
- GOTO PTR2
- +2 KILL RAFDA,RAIEN,RAMSG
- ASK ; don't ask, if from Img pkg or Kurzweil
- IF $GET(RARIC)
- GOTO UPD
- IF $DATA(RAQUIET)
- GOTO UPD
- +1 IF $PIECE(^RA(72,+RA3,0),"^",3)=0
- Begin DoDot:1
- +2 WRITE !!,"Case ",RA1," of this print set has been cancelled."
- +3 WRITE !,"Do you want to include it in the report anyway"
- +4 SET %=2
- DO YN^DICN
- +5 IF %>0
- WRITE "...",$SELECT(%=2:"Ex",%=1:"In",1:""),"clude case ",RA1
- +6 QUIT
- End DoDot:1
- IF %=2
- GOTO PTR2
- IF %'=1
- GOTO ASK
- +7 ; update file #70, field REPORT TEXT
- UPD SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RA2,0),U,17)=RARPT
- +1 DO INSERT
- +2 IF RAXIT
- QUIT
- GOTO PTR2
- INSERT ; add subrec to file #74's subfile #74.05
- +1 ; P47 - if SSAN in use set OTHER CASES in Printset to SSAN format
- +2 IF $LENGTH(RARPTN,"-")>2
- SET RAFDA(74.05,"?+2,"_RARPT_",",.01)=$PIECE(RARPTN,"-",1,2)_"-"_RA1
- +3 IF $LENGTH(RARPTN,"-")<3
- SET RAFDA(74.05,"?+2,"_RARPT_",",.01)=$PIECE(RARPTN,"-")_"-"_RA1
- +4 DO UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
- +5 IF $DATA(RAMSG)
- Begin DoDot:1
- +6 SET RAXIT=1
- IF $GET(RARIC)
- QUIT
- +7 ;error detected
- IF '$DATA(RAQUIET)
- WRITE !!,$CHAR(7),"Error encountered while setting sub-records (routine RARTE2)",!
- SET RAOUT=$$EOS^RAUTL5()
- QUIT
- +8 SET RAERR="Error encountered while setting sub-recs from RARTE2"
- End DoDot:1
- QUIT
- +9 QUIT
- DEL17(RAIEN) ;del other print set members' pointer to #74
- +1 IF '$DATA(RADFN)!('$DATA(RADTI))
- QUIT
- +2 NEW RA4,RA1
- DO EN3^RAUTL20(.RA4)
- +3 IF '$ORDER(RA4(0))
- QUIT
- +4 SET RA1=""
- D18 SET RA1=$ORDER(RA4(RA1))
- IF RA1=""
- QUIT
- +1 ; kill xrefs, if any, for file #70's REPORT TEXT
- +2 SET DA(2)=RADFN
- SET DA(1)=RADTI
- SET DA=RA1
- +3 ; if this exam's piece 17 doesn't match RAIEN, then don't remove pc17
- +4 IF $PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RA1,0)),"^",17)'=RAIEN
- GOTO D18
- +5 DO ENKILL^RAXREF(70.03,17,RAIEN,.DA)
- +6 ; set REPORT TEXT to null
- +7 IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RA1,0))
- SET $PIECE(^(0),"^",17)=""
- +8 GOTO D18
- COPY ;copy physicians and diagnoses
- +1 IF '$DATA(RADFN)!('$DATA(RADTI))!('$DATA(RACNI))!('$DATA(RAMEMARR))!('$DATA(RADRS))
- QUIT
- +2 WRITE !!,"... now copying ",$SELECT(RADRS=1:"Diagnostic Codes",1:"Staff & Resident data")," to other cases in this print set ...",!
- +3 NEW RA1,RA2,RA3
- +4 ;prim res/staff
- NEW RA1PR,RA1PS
- +5 ; sec res/staff arrays--(ien subfile #70.11)=ien file #200
- NEW RA1SR,RA1SS
- +6 ; prim diag, then sec diags array
- NEW RA1PD,RA1SD
- +7 NEW RAFDA,RAIEN,RAMSG
- +8 ;prim res, prim staff, prim diag
- +9 SET RA1=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
- IF RADRS=2
- SET RA1PR=$PIECE(RA1,"^",12)
- SET RA1PS=$PIECE(RA1,"^",15)
- IF RADRS=1
- SET RA1PD=$PIECE(RA1,"^",13)
- +10 ;sec residents
- +11 IF RADRS=2
- IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",0))
- SET RA1=0
- FOR
- SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",RA1))
- IF +RA1'=RA1
- QUIT
- SET RA1SR(RA1)=+^(RA1,0)
- +12 ;sec staff
- +13 IF RADRS=2
- IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",0))
- SET RA1=0
- FOR
- SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",RA1))
- IF +RA1'=RA1
- QUIT
- SET RA1SS(RA1)=+^(RA1,0)
- +14 ;sec diagnoses
- +15 IF RADRS=1
- IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))
- SET RA1=0
- FOR
- SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RA1))
- IF +RA1'=RA1
- QUIT
- SET RA1SD(RA1)=+^(RA1,0)
- +16 ;loop thru other cases of this printset
- +17 SET RA1=0
- COPYLOOP ;skip what's done already
- SET RA1=$ORDER(RAMEMARR(RA1))
- IF RA1=""
- GOTO COPYREF
- IF RA1=RACNI
- GOTO COPYLOOP
- +1 ;
- +2 ; copy primary staff and resident via Fileman
- +3 IF RADRS=2
- Begin DoDot:1
- +4 SET DA(2)=RADFN
- SET DA(1)=RADTI
- SET DA=RA1
- +5 SET DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
- +6 SET DR="12////"_RA1PR_";15////"_RA1PS
- +7 ; no locking
- DO ^DIE
- KILL DA,DIE,DR
- +8 QUIT
- End DoDot:1
- +9 ;
- +10 ; copy primary diagnostic code via Fileman
- +11 IF RADRS=1
- Begin DoDot:1
- +12 SET DA(2)=RADFN
- SET DA(1)=RADTI
- SET DA=RA1
- +13 SET DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
- +14 SET DR="13////"_RA1PD
- +15 ; no locking
- DO ^DIE
- KILL DA,DIE,DR
- +16 QUIT
- End DoDot:1
- +17 ;
- +18 ;stem for dataserver call
- SET RA2=RA1_","_RADTI_","_RADFN
- +19 ;base vars for DIK call
- SET DA(3)=RADFN
- SET DA(2)=RADTI
- SET DA(1)=RA1
- +20 ; sec res
- IF RADRS=2
- SET RA3=0
- DO KIL3
- IF RAXIT
- GOTO Q
- +21 ; sec staff
- IF RADRS=2
- SET RA3=0
- DO KIL4
- IF RAXIT
- GOTO Q
- +22 ; sec diag
- IF RADRS=1
- SET RA3=0
- DO KIL5
- IF RAXIT
- GOTO Q
- +23 GOTO COPYLOOP
- KIL3 SET RA3=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RA1,"SRR",RA3))
- IF RA3=""
- GOTO COPY3
- +1 SET DA=RA3
- +2 SET DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""SRR"","
- +3 DO ^DIK
- +4 GOTO KIL3
- COPY3 KILL RAFDA,RAIEN,RAMSG
- SET RA3=$ORDER(RA1SR(RA3))
- IF 'RA3
- QUIT
- IF RAXIT
- QUIT
- UP3 ;
- +1 SET RAFDA(70.09,"?+2,"_RA2_",",.01)=RA1SR(RA3)
- +2 DO UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
- IF '$DATA(RAMSG)
- GOTO COPY3
- +3 SET RAXIT=1
- WRITE !!,$CHAR(7),"Error encountered while in adding rec ",RA3," to sub-file 70.09"
- QUIT
- KIL4 SET RA3=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RA1,"SSR",RA3))
- IF RA3=""
- GOTO COPY4
- +1 SET DA=RA3
- +2 SET DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""SSR"","
- +3 DO ^DIK
- +4 GOTO KIL4
- COPY4 KILL RAFDA,RAIEN,RAMSG
- SET RA3=$ORDER(RA1SS(RA3))
- IF 'RA3
- QUIT
- IF RAXIT
- QUIT
- UP4 ;
- +1 SET RAFDA(70.11,"?+2,"_RA2_",",.01)=RA1SS(RA3)
- +2 DO UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
- IF '$DATA(RAMSG)
- GOTO COPY4
- +3 SET RAXIT=1
- WRITE !!,$CHAR(7),"Error encountered while in adding rec ",RA3," to sub-file 70.11"
- QUIT
- KIL5 SET RA3=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RA1,"DX",RA3))
- IF RA3=""
- GOTO COPY5
- +1 SET DA=RA3
- +2 SET DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""DX"","
- +3 DO ^DIK
- +4 GOTO KIL5
- COPY5 KILL RAFDA,RAIEN,RAMSG
- SET RA3=$ORDER(RA1SD(RA3))
- IF 'RA3
- QUIT
- IF RAXIT
- QUIT
- UP5 ;
- +1 SET RAFDA(70.14,"?+2,"_RA2_",",.01)=RA1SD(RA3)
- +2 DO UPDATE^DIE("","RAFDA","RAIEN","RAMSG")
- IF '$DATA(RAMSG)
- GOTO COPY5
- +3 SET RAXIT=1
- WRITE !!,$CHAR(7),"Error encountered while in adding rec ",RA3," to sub-file 70.14"
- QUIT
- COPYREF ; clear out Fileman vars and quit
- +1 KILL DA,DIK
- +2 ; don't need to re-xref again
- QUIT
- Q KILL DA
- QUIT
