Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DVBCUTA2

DVBCUTA2.m

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