DVBCUTA2 ;ALB/GTS-AMIE C&P UTILITY ROUTINE A-2 ; 2/8/95 11:15 AM
;;2.7;AMIE;;Apr 10, 1995
;
;** Version Changes
; 2.7 - New routine (Enhc 15)
;
INSUFXM ;** Insufficient exam information entry (Called from DVBCREDT)
K DIR,Y
N EXMNM,XMSTAT,XMDA,REQDA
S REQDA=SAVEDA
I $D(^DVB(396.3,REQDA,5)),NODE5=^DVB(396.3,REQDA,5) DO
.W !
.D XMQS
.I +Y=1 DO
..K DIR,Y
..K DTOUT,DUOUT
..F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:(XMDA=""!($D(DTOUT))) D XMUPDT
.K DIR,Y
I $D(^DVB(396.3,REQDA,5)),(NODE5'=^DVB(396.3,REQDA,5)) DO
.D EXMEDIT
.I $D(XMEDT) DO
..K DTOUT
..D SAVEXAM ;**Save exam info in case time out
..F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:(XMDA=""!($D(DTOUT))) D XMUPDT
..I $D(DTOUT) D RESTLINK,RESTXAMS ;**Restore link and exam info
.I '$D(XMEDT) DO ;**Update original provider automatically
..F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:XMDA="" D PROVUP
K Y,^TMP($J,"NEW"),XMEDT,^TMP("DVBC",$J,396.4)
Q
;
XMUPDT ;** Update exam insuf info
W @IOF
S EXMNM=$P(^DVB(396.6,$P(^DVB(396.4,XMDA,0),U,3),0),U,1)
S ^TMP($J,"NEW",EXMNM)=$P(^DVB(396.4,XMDA,0),U,3)
S XMSTAT=$P(^DVB(396.4,XMDA,0),U,4),Y=XMDA ;**Set var's for INSXM
N DVBAINDA S DVBAINDA=$P(^DVB(396.3,REQDA,5),U,1)
D:(XMSTAT'["X"&(XMSTAT'="T")) INSXM^DVBCUTA1 ;**Update exam info
Q
;
PROVUP ;** Auto update original provider
K DIE,Y,DR,DA
N DVBAXMTP,DVBAPROV,DVBAORXM,DVBACMND,DVBAINDA
S DVBAINDA=+$P(^DVB(396.3,REQDA,5),U,1)
S DVBAXMTP=$P(^DVB(396.4,XMDA,0),U,3),DVBAORXM="",DVBAPROV=""
S DVBACMND="S DVBAORXM=$O(^DVB(396.4,""ARQ"_DVBAINDA_""","_DVBAXMTP_",DVBAORXM))"
N XREF S XREF="ARQ"_DVBAINDA
I $D(^DVB(396.4,XREF,DVBAXMTP)) X DVBACMND ;**Return insuff exam IEN
S:+DVBAORXM>0 DVBAPROV=$P(^DVB(396.4,DVBAORXM,0),U,7)
I DVBAPROV="" DO
.S DVBAPROV="Unknown" ;**Bad 'ARQ' X-Ref
K DVBADMNM
I +DVBAORXM>0,($D(^DVB(396.4,DVBAORXM,"TRAN"))) DO
.S DVBADMNM=$P(^DIC(4.2,+$P(^DVB(396.4,DVBAORXM,"TRAN"),U,3),0),U,1)
.S DVBADMNM=$P(DVBADMNM,".",1)
S:$D(DVBADMNM) DVBAPROV=DVBAPROV_" at "_DVBADMNM
S DIE="^DVB(396.4,",DR=".12////^S X=DVBAPROV",DA=XMDA
D ^DIE K DIE,DR,DA
Q
;
RESTLINK ;** Restore 2507 link info (Called from ^DVBCREDT & INSUFXM)
N LINKDA,DAYS
S LINKDA=$P(NODE5,U,1)
S DAYS=$P(NODE5,U,2)
S:LINKDA="" LINKDA="@"
S:DAYS="" DAYS="@"
K DA,DR,DIE
S DIE="^DVB(396.3,"
S DA=REQDA,DR="44////^S X=LINKDA;45////^S X=DAYS"
D ^DIE
K DA,DR,DIE
S TVAR(1,0)="1,3,0,2:1,0^All exams must be reviewed....Insufficient link and info not updated!"
D WR^DVBAUTL4("TVAR")
K TVAR
D CONTMES^DVBCUTL4
Q
;
EXMEDIT ;** Ask user to edit exams
I '$D(UPDT2507)!((+$P(^DVB(396.3,REQDA,5),U,1)>0)&($D(UPDT2507))) DO
.D XMQS
.S:+Y=1 XMEDT=""
I (+$P(^DVB(396.3,REQDA,5),U,1)'>0)&($D(UPDT2507)) DO
.S TVAR(1,0)="1,3,0,2:1,0^Review exam info for a new Original Provider."
.D WR^DVBAUTL4("TVAR")
.K TVAR
.S XMEDT=""
.D CONTMES^DVBCUTL4
Q
;
XMQS ;** Edit exams?
S DIR(0)="Y^AO",DIR("A")="Do you want to edit the insufficient information for the exams"
S DIR("?",1)="Enter Yes to edit Remarks, Insufficient Reason and Original Providor (when"
S DIR("?")=" appropriate). Enter No to keep the current information."
S DIR("B")="NO" D ^DIR
Q
;
SAVEXAM ;** Save exam info prior to edit
N REMDA,XMDA
F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:XMDA="" DO
.S ^TMP("DVBC",$J,396.4,XMDA,0)=$P(^DVB(396.4,XMDA,0),U,11)_"^"_$P(^DVB(396.4,XMDA,0),U,12)
.F REMDA=0:0 S REMDA=$O(^DVB(396.4,XMDA,"INREM",REMDA)) Q:REMDA="" DO
..S ^TMP("DVBC",$J,396.4,XMDA,"INREM",REMDA,0)=^DVB(396.4,XMDA,"INREM",REMDA,0)
Q
;
RESTXAMS ;** Restore exam information (Called from INSUFXM)
N REMDA,XMDA,REASDA,PROV,REMARK,LNCNT,XMSTAT
F XMDA=0:0 S XMDA=$O(^DVB(396.4,"C",REQDA,XMDA)) Q:XMDA="" DO
.S XMSTAT=$P(^DVB(396.4,XMDA,0),U,4)
.I (XMSTAT'["X")&(XMSTAT'["T") DO
..S REASDA=$P(^TMP("DVBC",$J,396.4,XMDA,0),U,1)
..S PROV=$P(^TMP("DVBC",$J,396.4,XMDA,0),U,2)
..K DIE,DR,DA
..S DIE="^DVB(396.4,",DR=".11////^S X=REASDA;.12////^S X=PROV;80////@",DA=XMDA
..D ^DIE
..S LNCNT=0
..S:'$D(^DVB(396.4,XMDA,"INREM",0)) ^DVB(396.4,XMDA,"INREM",0)="^^0^0^"_DT_"^"
..F REMDA=0:0 S REMDA=$O(^TMP("DVBC",$J,396.4,XMDA,"INREM",REMDA)) Q:REMDA="" DO
...S REMARK=^TMP("DVBC",$J,396.4,XMDA,"INREM",REMDA,0)
...S LNCNT=LNCNT+1
...S ^DVB(396.4,XMDA,"INREM",REMDA,0)=REMARK
..S ^DVB(396.4,XMDA,"INREM",0)="^^"_LNCNT_"^"_LNCNT_"^"_DT_"^"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCUTA2 4487 printed Dec 13, 2024@01:49:07 Page 2
DVBCUTA2 ;ALB/GTS-AMIE C&P UTILITY ROUTINE A-2 ; 2/8/95 11:15 AM
+1 ;;2.7;AMIE;;Apr 10, 1995
+2 ;
+3 ;** Version Changes
+4 ; 2.7 - New routine (Enhc 15)
+5 ;
INSUFXM ;** Insufficient exam information entry (Called from DVBCREDT)
+1 KILL DIR,Y
+2 NEW EXMNM,XMSTAT,XMDA,REQDA
+3 SET REQDA=SAVEDA
+4 IF $DATA(^DVB(396.3,REQDA,5))
IF NODE5=^DVB(396.3,REQDA,5)
Begin DoDot:1
+5 WRITE !
+6 DO XMQS
+7 IF +Y=1
Begin DoDot:2
+8 KILL DIR,Y
+9 KILL DTOUT,DUOUT
+10 FOR XMDA=0:0
SET XMDA=$ORDER(^DVB(396.4,"C",REQDA,XMDA))
if (XMDA=""!($DATA(DTOUT)))
QUIT
DO XMUPDT
End DoDot:2
+11 KILL DIR,Y
End DoDot:1
+12 IF $DATA(^DVB(396.3,REQDA,5))
IF (NODE5'=^DVB(396.3,REQDA,5))
Begin DoDot:1
+13 DO EXMEDIT
+14 IF $DATA(XMEDT)
Begin DoDot:2
+15 KILL DTOUT
+16 ;**Save exam info in case time out
DO SAVEXAM
+17 FOR XMDA=0:0
SET XMDA=$ORDER(^DVB(396.4,"C",REQDA,XMDA))
if (XMDA=""!($DATA(DTOUT)))
QUIT
DO XMUPDT
+18 ;**Restore link and exam info
IF $DATA(DTOUT)
DO RESTLINK
DO RESTXAMS
End DoDot:2
+19 ;**Update original provider automatically
IF '$DATA(XMEDT)
Begin DoDot:2
+20 FOR XMDA=0:0
SET XMDA=$ORDER(^DVB(396.4,"C",REQDA,XMDA))
if XMDA=""
QUIT
DO PROVUP
End DoDot:2
End DoDot:1
+21 KILL Y,^TMP($JOB,"NEW"),XMEDT,^TMP("DVBC",$JOB,396.4)
+22 QUIT
+23 ;
XMUPDT ;** Update exam insuf info
+1 WRITE @IOF
+2 SET EXMNM=$PIECE(^DVB(396.6,$PIECE(^DVB(396.4,XMDA,0),U,3),0),U,1)
+3 SET ^TMP($JOB,"NEW",EXMNM)=$PIECE(^DVB(396.4,XMDA,0),U,3)
+4 ;**Set var's for INSXM
SET XMSTAT=$PIECE(^DVB(396.4,XMDA,0),U,4)
SET Y=XMDA
+5 NEW DVBAINDA
SET DVBAINDA=$PIECE(^DVB(396.3,REQDA,5),U,1)
+6 ;**Update exam info
if (XMSTAT'["X"&(XMSTAT'="T"))
DO INSXM^DVBCUTA1
+7 QUIT
+8 ;
PROVUP ;** Auto update original provider
+1 KILL DIE,Y,DR,DA
+2 NEW DVBAXMTP,DVBAPROV,DVBAORXM,DVBACMND,DVBAINDA
+3 SET DVBAINDA=+$PIECE(^DVB(396.3,REQDA,5),U,1)
+4 SET DVBAXMTP=$PIECE(^DVB(396.4,XMDA,0),U,3)
SET DVBAORXM=""
SET DVBAPROV=""
+5 SET DVBACMND="S DVBAORXM=$O(^DVB(396.4,""ARQ"_DVBAINDA_""","_DVBAXMTP_",DVBAORXM))"
+6 NEW XREF
SET XREF="ARQ"_DVBAINDA
+7 ;**Return insuff exam IEN
IF $DATA(^DVB(396.4,XREF,DVBAXMTP))
XECUTE DVBACMND
+8 if +DVBAORXM>0
SET DVBAPROV=$PIECE(^DVB(396.4,DVBAORXM,0),U,7)
+9 IF DVBAPROV=""
Begin DoDot:1
+10 ;**Bad 'ARQ' X-Ref
SET DVBAPROV="Unknown"
End DoDot:1
+11 KILL DVBADMNM
+12 IF +DVBAORXM>0
IF ($DATA(^DVB(396.4,DVBAORXM,"TRAN")))
Begin DoDot:1
+13 SET DVBADMNM=$PIECE(^DIC(4.2,+$PIECE(^DVB(396.4,DVBAORXM,"TRAN"),U,3),0),U,1)
+14 SET DVBADMNM=$PIECE(DVBADMNM,".",1)
End DoDot:1
+15 if $DATA(DVBADMNM)
SET DVBAPROV=DVBAPROV_" at "_DVBADMNM
+16 SET DIE="^DVB(396.4,"
SET DR=".12////^S X=DVBAPROV"
SET DA=XMDA
+17 DO ^DIE
KILL DIE,DR,DA
+18 QUIT
+19 ;
RESTLINK ;** Restore 2507 link info (Called from ^DVBCREDT & INSUFXM)
+1 NEW LINKDA,DAYS
+2 SET LINKDA=$PIECE(NODE5,U,1)
+3 SET DAYS=$PIECE(NODE5,U,2)
+4 if LINKDA=""
SET LINKDA="@"
+5 if DAYS=""
SET DAYS="@"
+6 KILL DA,DR,DIE
+7 SET DIE="^DVB(396.3,"
+8 SET DA=REQDA
SET DR="44////^S X=LINKDA;45////^S X=DAYS"
+9 DO ^DIE
+10 KILL DA,DR,DIE
+11 SET TVAR(1,0)="1,3,0,2:1,0^All exams must be reviewed....Insufficient link and info not updated!"
+12 DO WR^DVBAUTL4("TVAR")
+13 KILL TVAR
+14 DO CONTMES^DVBCUTL4
+15 QUIT
+16 ;
EXMEDIT ;** Ask user to edit exams
+1 IF '$DATA(UPDT2507)!((+$PIECE(^DVB(396.3,REQDA,5),U,1)>0)&($DATA(UPDT2507)))
Begin DoDot:1
+2 DO XMQS
+3 if +Y=1
SET XMEDT=""
End DoDot:1
+4 IF (+$PIECE(^DVB(396.3,REQDA,5),U,1)'>0)&($DATA(UPDT2507))
Begin DoDot:1
+5 SET TVAR(1,0)="1,3,0,2:1,0^Review exam info for a new Original Provider."
+6 DO WR^DVBAUTL4("TVAR")
+7 KILL TVAR
+8 SET XMEDT=""
+9 DO CONTMES^DVBCUTL4
End DoDot:1
+10 QUIT
+11 ;
XMQS ;** Edit exams?
+1 SET DIR(0)="Y^AO"
SET DIR("A")="Do you want to edit the insufficient information for the exams"
+2 SET DIR("?",1)="Enter Yes to edit Remarks, Insufficient Reason and Original Providor (when"
+3 SET DIR("?")=" appropriate). Enter No to keep the current information."
+4 SET DIR("B")="NO"
DO ^DIR
+5 QUIT
+6 ;
SAVEXAM ;** Save exam info prior to edit
+1 NEW REMDA,XMDA
+2 FOR XMDA=0:0
SET XMDA=$ORDER(^DVB(396.4,"C",REQDA,XMDA))
if XMDA=""
QUIT
Begin DoDot:1
+3 SET ^TMP("DVBC",$JOB,396.4,XMDA,0)=$PIECE(^DVB(396.4,XMDA,0),U,11)_"^"_$PIECE(^DVB(396.4,XMDA,0),U,12)
+4 FOR REMDA=0:0
SET REMDA=$ORDER(^DVB(396.4,XMDA,"INREM",REMDA))
if REMDA=""
QUIT
Begin DoDot:2
+5 SET ^TMP("DVBC",$JOB,396.4,XMDA,"INREM",REMDA,0)=^DVB(396.4,XMDA,"INREM",REMDA,0)
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
RESTXAMS ;** Restore exam information (Called from INSUFXM)
+1 NEW REMDA,XMDA,REASDA,PROV,REMARK,LNCNT,XMSTAT
+2 FOR XMDA=0:0
SET XMDA=$ORDER(^DVB(396.4,"C",REQDA,XMDA))
if XMDA=""
QUIT
Begin DoDot:1
+3 SET XMSTAT=$PIECE(^DVB(396.4,XMDA,0),U,4)
+4 IF (XMSTAT'["X")&(XMSTAT'["T")
Begin DoDot:2
+5 SET REASDA=$PIECE(^TMP("DVBC",$JOB,396.4,XMDA,0),U,1)
+6 SET PROV=$PIECE(^TMP("DVBC",$JOB,396.4,XMDA,0),U,2)
+7 KILL DIE,DR,DA
+8 SET DIE="^DVB(396.4,"
SET DR=".11////^S X=REASDA;.12////^S X=PROV;80////@"
SET DA=XMDA
+9 DO ^DIE
+10 SET LNCNT=0
+11 if '$DATA(^DVB(396.4,XMDA,"INREM",0))
SET ^DVB(396.4,XMDA,"INREM",0)="^^0^0^"_DT_"^"
+12 FOR REMDA=0:0
SET REMDA=$ORDER(^TMP("DVBC",$JOB,396.4,XMDA,"INREM",REMDA))
if REMDA=""
QUIT
Begin DoDot:3
+13 SET REMARK=^TMP("DVBC",$JOB,396.4,XMDA,"INREM",REMDA,0)
+14 SET LNCNT=LNCNT+1
+15 SET ^DVB(396.4,XMDA,"INREM",REMDA,0)=REMARK
End DoDot:3
+16 SET ^DVB(396.4,XMDA,"INREM",0)="^^"_LNCNT_"^"_LNCNT_"^"_DT_"^"
End DoDot:2
End DoDot:1
+17 QUIT
