- DVBCUTA3 ;ALB/GTS-AMIE C&P UTILITY ROUTINE A-3 ; 2/10/95 11:15 AM
- ;;2.7;AMIE;;Apr 10, 1995
- ;
- ;** Version Changes
- ; 2.7 - New routine (Enhc 15)
- ;
- INRSLK() ;** Lookup insufficient reason
- N REASVAR,DVBAOUT,REASIN
- S REASVAR=-1,REASIN=""
- K DTOUT,DUOUT
- F Q:($D(DTOUT)!(+REASVAR>0)!($D(DVBAOUT))) DO
- .I '$D(DVBAXMDA) DO
- ..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
- ..S:'$T DVBAOUT=""
- .I $D(DVBAXMDA),(+DVBAXMDA'>0) DO
- ..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
- ..S:'$T DVBAOUT=""
- .I $D(DVBAXMDA),(+DVBAXMDA>0&(+$P(^DVB(396.4,DVBAXMDA,0),U,11)'>0)) DO
- ..R !,"INSUFFICIENT REASON: ",REASIN:DTIME
- ..S:'$T DVBAOUT=""
- .I $D(DVBAXMDA),(+DVBAXMDA>0&(+$P(^DVB(396.4,DVBAXMDA,0),U,11)>0)) DO
- ..W !,"INSUFFICIENT REASON: "
- ..S:'$T DVBAOUT=""
- ..I +$P(^DVB(396.4,DVBAXMDA,0),U,11)>0 DO
- ...W $P(^DVB(396.94,$P(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)_"//"
- ..R REASIN:DTIME
- ..S:'$T DVBAOUT=""
- ..I '$D(DVBAOUT),(REASIN="") S REASIN=$P(^DVB(396.94,$P(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)
- .I REASIN="^" DO
- ..S TVAR(1,0)="0,0,0,0,0^NOT ALLOWED"
- ..D WR^DVBAUTL4("TVAR")
- ..K TVAR
- .I '$D(DVBAOUT),(REASIN="") S REASIN="^"
- .I REASIN="^" DO
- ..S TVAR(1,0)="0,0,0,0,0^??"
- ..S TVAR(2,0)="0,5,0,1,0^Enter the insufficient reason this exam is being returned."
- ..S TVAR(3,0)="0,1,0,1,0^ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
- ..D WR^DVBAUTL4("TVAR")
- ..K TVAR
- .I REASIN="?" DO
- ..K DIR S DIR(0)="YAO"
- ..S DIR("A",1)=" Enter the insufficient reason this exam is being returned. "
- ..S DIR("A",2)=" ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
- ..S DIR("A")=" DO YOU WANT THE ENTIRE 13-ENTRY 2507 INSUFFICIENT REASONS LIST? "
- ..D ^DIR
- ..D:+Y=1 RESHELP
- ..K Y,DIR
- .I REASIN["??" DO
- ..S TVAR(1,0)="0,0,0,1,0^This field contains a pointer to the Insufficient Reason file (396.94)."
- ..D WR^DVBAUTL4("TVAR")
- ..K TVAR
- ..D RESHELP
- .I REASIN'="^",(REASIN'["?") DO
- ..S DIC="^DVB(396.94,",X=REASIN,DIC(0)="MQE"
- ..D ^DIC
- ..S REASVAR=Y
- ..K DIC,X,Y
- S:($D(DTOUT)!($D(DVBAOUT))) REASVAR=-1
- Q REASVAR
- ;
- RESHELP ;** Help for insufficient reasons
- N LPVAR
- S TVAR(1,0)="0,0,0,2,0^CHOOSE FROM:"
- D WR^DVBAUTL4("TVAR")
- K TVAR
- F LPVAR=0:0 S LPVAR=$O(^DVB(396.94,LPVAR)) Q:+LPVAR=0 DO
- .S TVAR(1,0)="0,3:0,0,1,0^"_$P(^DVB(396.94,LPVAR,0),U,1)
- .D WR^DVBAUTL4("TVAR")
- .K TVAR
- W !
- Q
- ;
- LNKLIST ;** List links for user
- I '$D(TMP("DVBC LINK")) DO
- .S TVAR(1,0)="0,0,0,1,0^There are no links to this 2507 request."
- .D WR^DVBAUTL4("TVAR")
- .K TVAR
- .D CONTMES^DVBCUTL4
- I $D(TMP("DVBC LINK")) DO
- .N DVBAMORE
- .W !,?2,"Current Appointment Links",!
- .W !,?1,"Initial Appt",?21,"Clock Stop Appt",?41,"Current Appt",?61,"Clinic"
- .S ARYDA=""
- .N GETOUT
- .F ARYDA=1:1 Q:('$D(TMP("DVBC LINK",ARYDA))!($D(GETOUT))) DO
- ..S SELDA=""
- ..S SELDA=$O(TMP("DVBC LINK",ARYDA,SELDA))
- ..W !,?1,$P(TMP("DVBC LINK",ARYDA,SELDA),U,1)
- ..W ?21,$P(TMP("DVBC LINK",ARYDA,SELDA),U,2),?41,$P(TMP("DVBC LINK",ARYDA,SELDA),U,3)
- ..W ?61,$E($P(TMP("DVBC LINK",ARYDA,SELDA),U,4),1,18)
- ..S DVBAMORE=$O(TMP("DVBC LINK",ARYDA))
- ..I (+DVBAMORE'>0)!(+DVBAMORE>0&(ARYDA#5=0)) DO
- ...K DIR
- ...S DIR(0)="F,O^^",DIR("A")="Enter [Return] to continue or ""^"" to exit"
- ...K GETOUT D ^DIR S:$D(DTOUT)!($D(DUOUT)) GETOUT=1
- ...I '$D(GETOUT) W ! K DIR,DIRUT,X
- .K TMP("DVBC LINK"),ARYDA,SELDA,DIR,X
- Q
- ;
- LNKARY(REQDA,DVBADFN) ;** Set up the link array (In TMP local)
- N LKDA,ARYDA
- S LKDA="",ARYDA=0
- F S LKDA=$O(^DVB(396.95,"AR",REQDA,LKDA)) Q:+LKDA=0 DO
- .S ARYDA=ARYDA+1
- .S Y=$P(^DVB(396.95,LKDA,0),U,1) X ^DD("DD")
- .S TMP("DVBC LINK",ARYDA,LKDA)=Y K Y
- .S Y=$P(^DVB(396.95,LKDA,0),U,2) X ^DD("DD")
- .S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y K Y
- .S Y=$P(^DVB(396.95,LKDA,0),U,3) X ^DD("DD")
- .S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y K Y
- .S DA=DVBADFN,DA(2.98)=$P(^DVB(396.95,LKDA,0),U,3),DR="1900",DR(2.98)=".01",DIC=2
- .S DIQ="DVBACLIN" K ^UTILITY("DIQ",$J)
- .D EN^DIQ1 K ^UTILITY("DIQ",$J)
- .S TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_DVBACLIN(2.98,$P(^DVB(396.95,LKDA,0),U,3),.01)
- .K DVBACLIN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCUTA3 4185 printed Jan 18, 2025@02:50:22 Page 2
- DVBCUTA3 ;ALB/GTS-AMIE C&P UTILITY ROUTINE A-3 ; 2/10/95 11:15 AM
- +1 ;;2.7;AMIE;;Apr 10, 1995
- +2 ;
- +3 ;** Version Changes
- +4 ; 2.7 - New routine (Enhc 15)
- +5 ;
- INRSLK() ;** Lookup insufficient reason
- +1 NEW REASVAR,DVBAOUT,REASIN
- +2 SET REASVAR=-1
- SET REASIN=""
- +3 KILL DTOUT,DUOUT
- +4 FOR
- if ($DATA(DTOUT)!(+REASVAR>0)!($DATA(DVBAOUT)))
- QUIT
- Begin DoDot:1
- +5 IF '$DATA(DVBAXMDA)
- Begin DoDot:2
- +6 READ !,"INSUFFICIENT REASON: ",REASIN:DTIME
- +7 if '$TEST
- SET DVBAOUT=""
- End DoDot:2
- +8 IF $DATA(DVBAXMDA)
- IF (+DVBAXMDA'>0)
- Begin DoDot:2
- +9 READ !,"INSUFFICIENT REASON: ",REASIN:DTIME
- +10 if '$TEST
- SET DVBAOUT=""
- End DoDot:2
- +11 IF $DATA(DVBAXMDA)
- IF (+DVBAXMDA>0&(+$PIECE(^DVB(396.4,DVBAXMDA,0),U,11)'>0))
- Begin DoDot:2
- +12 READ !,"INSUFFICIENT REASON: ",REASIN:DTIME
- +13 if '$TEST
- SET DVBAOUT=""
- End DoDot:2
- +14 IF $DATA(DVBAXMDA)
- IF (+DVBAXMDA>0&(+$PIECE(^DVB(396.4,DVBAXMDA,0),U,11)>0))
- Begin DoDot:2
- +15 WRITE !,"INSUFFICIENT REASON: "
- +16 if '$TEST
- SET DVBAOUT=""
- +17 IF +$PIECE(^DVB(396.4,DVBAXMDA,0),U,11)>0
- Begin DoDot:3
- +18 WRITE $PIECE(^DVB(396.94,$PIECE(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)_"//"
- End DoDot:3
- +19 READ REASIN:DTIME
- +20 if '$TEST
- SET DVBAOUT=""
- +21 IF '$DATA(DVBAOUT)
- IF (REASIN="")
- SET REASIN=$PIECE(^DVB(396.94,$PIECE(^DVB(396.4,DVBAXMDA,0),U,11),0),U,1)
- End DoDot:2
- +22 IF REASIN="^"
- Begin DoDot:2
- +23 SET TVAR(1,0)="0,0,0,0,0^NOT ALLOWED"
- +24 DO WR^DVBAUTL4("TVAR")
- +25 KILL TVAR
- End DoDot:2
- +26 IF '$DATA(DVBAOUT)
- IF (REASIN="")
- SET REASIN="^"
- +27 IF REASIN="^"
- Begin DoDot:2
- +28 SET TVAR(1,0)="0,0,0,0,0^??"
- +29 SET TVAR(2,0)="0,5,0,1,0^Enter the insufficient reason this exam is being returned."
- +30 SET TVAR(3,0)="0,1,0,1,0^ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
- +31 DO WR^DVBAUTL4("TVAR")
- +32 KILL TVAR
- End DoDot:2
- +33 IF REASIN="?"
- Begin DoDot:2
- +34 KILL DIR
- SET DIR(0)="YAO"
- +35 SET DIR("A",1)=" Enter the insufficient reason this exam is being returned. "
- +36 SET DIR("A",2)=" ANSWER WITH 2507 INSUFFICIENT REASONS INSUFFICIENT CODE"
- +37 SET DIR("A")=" DO YOU WANT THE ENTIRE 13-ENTRY 2507 INSUFFICIENT REASONS LIST? "
- +38 DO ^DIR
- +39 if +Y=1
- DO RESHELP
- +40 KILL Y,DIR
- End DoDot:2
- +41 IF REASIN["??"
- Begin DoDot:2
- +42 SET TVAR(1,0)="0,0,0,1,0^This field contains a pointer to the Insufficient Reason file (396.94)."
- +43 DO WR^DVBAUTL4("TVAR")
- +44 KILL TVAR
- +45 DO RESHELP
- End DoDot:2
- +46 IF REASIN'="^"
- IF (REASIN'["?")
- Begin DoDot:2
- +47 SET DIC="^DVB(396.94,"
- SET X=REASIN
- SET DIC(0)="MQE"
- +48 DO ^DIC
- +49 SET REASVAR=Y
- +50 KILL DIC,X,Y
- End DoDot:2
- End DoDot:1
- +51 if ($DATA(DTOUT)!($DATA(DVBAOUT)))
- SET REASVAR=-1
- +52 QUIT REASVAR
- +53 ;
- RESHELP ;** Help for insufficient reasons
- +1 NEW LPVAR
- +2 SET TVAR(1,0)="0,0,0,2,0^CHOOSE FROM:"
- +3 DO WR^DVBAUTL4("TVAR")
- +4 KILL TVAR
- +5 FOR LPVAR=0:0
- SET LPVAR=$ORDER(^DVB(396.94,LPVAR))
- if +LPVAR=0
- QUIT
- Begin DoDot:1
- +6 SET TVAR(1,0)="0,3:0,0,1,0^"_$PIECE(^DVB(396.94,LPVAR,0),U,1)
- +7 DO WR^DVBAUTL4("TVAR")
- +8 KILL TVAR
- End DoDot:1
- +9 WRITE !
- +10 QUIT
- +11 ;
- LNKLIST ;** List links for user
- +1 IF '$DATA(TMP("DVBC LINK"))
- Begin DoDot:1
- +2 SET TVAR(1,0)="0,0,0,1,0^There are no links to this 2507 request."
- +3 DO WR^DVBAUTL4("TVAR")
- +4 KILL TVAR
- +5 DO CONTMES^DVBCUTL4
- End DoDot:1
- +6 IF $DATA(TMP("DVBC LINK"))
- Begin DoDot:1
- +7 NEW DVBAMORE
- +8 WRITE !,?2,"Current Appointment Links",!
- +9 WRITE !,?1,"Initial Appt",?21,"Clock Stop Appt",?41,"Current Appt",?61,"Clinic"
- +10 SET ARYDA=""
- +11 NEW GETOUT
- +12 FOR ARYDA=1:1
- if ('$DATA(TMP("DVBC LINK",ARYDA))!($DATA(GETOUT)))
- QUIT
- Begin DoDot:2
- +13 SET SELDA=""
- +14 SET SELDA=$ORDER(TMP("DVBC LINK",ARYDA,SELDA))
- +15 WRITE !,?1,$PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,1)
- +16 WRITE ?21,$PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,2),?41,$PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,3)
- +17 WRITE ?61,$EXTRACT($PIECE(TMP("DVBC LINK",ARYDA,SELDA),U,4),1,18)
- +18 SET DVBAMORE=$ORDER(TMP("DVBC LINK",ARYDA))
- +19 IF (+DVBAMORE'>0)!(+DVBAMORE>0&(ARYDA#5=0))
- Begin DoDot:3
- +20 KILL DIR
- +21 SET DIR(0)="F,O^^"
- SET DIR("A")="Enter [Return] to continue or ""^"" to exit"
- +22 KILL GETOUT
- DO ^DIR
- if $DATA(DTOUT)!($DATA(DUOUT))
- SET GETOUT=1
- +23 IF '$DATA(GETOUT)
- WRITE !
- KILL DIR,DIRUT,X
- End DoDot:3
- End DoDot:2
- +24 KILL TMP("DVBC LINK"),ARYDA,SELDA,DIR,X
- End DoDot:1
- +25 QUIT
- +26 ;
- LNKARY(REQDA,DVBADFN) ;** Set up the link array (In TMP local)
- +1 NEW LKDA,ARYDA
- +2 SET LKDA=""
- SET ARYDA=0
- +3 FOR
- SET LKDA=$ORDER(^DVB(396.95,"AR",REQDA,LKDA))
- if +LKDA=0
- QUIT
- Begin DoDot:1
- +4 SET ARYDA=ARYDA+1
- +5 SET Y=$PIECE(^DVB(396.95,LKDA,0),U,1)
- XECUTE ^DD("DD")
- +6 SET TMP("DVBC LINK",ARYDA,LKDA)=Y
- KILL Y
- +7 SET Y=$PIECE(^DVB(396.95,LKDA,0),U,2)
- XECUTE ^DD("DD")
- +8 SET TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y
- KILL Y
- +9 SET Y=$PIECE(^DVB(396.95,LKDA,0),U,3)
- XECUTE ^DD("DD")
- +10 SET TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_Y
- KILL Y
- +11 SET DA=DVBADFN
- SET DA(2.98)=$PIECE(^DVB(396.95,LKDA,0),U,3)
- SET DR="1900"
- SET DR(2.98)=".01"
- SET DIC=2
- +12 SET DIQ="DVBACLIN"
- KILL ^UTILITY("DIQ",$JOB)
- +13 DO EN^DIQ1
- KILL ^UTILITY("DIQ",$JOB)
- +14 SET TMP("DVBC LINK",ARYDA,LKDA)=TMP("DVBC LINK",ARYDA,LKDA)_"^"_DVBACLIN(2.98,$PIECE(^DVB(396.95,LKDA,0),U,3),.01)
- +15 KILL DVBACLIN
- End DoDot:1
- +16 QUIT