DIFROMSS ;SCISC/DCL-DIFROM SERVER/DATA SORT LIST/SB-DD/HDR2P ;6/2/96 18:55
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
Q
SEL(DIFRFILE,DIFRX) ;Extrinsic function to return resolved value for
;freetext pointer
;FILE,X-VALUE
N D,DIC,DIE,DIX,DIY,DO,DS,X,Y
N %,%K,%Y,DA,D0,D1,D2,D3
S DIC="^DIBT(",DIC(0)="QEMZ",X=DIFRX
S DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9"
D ^DIC
Q:Y'>0 ""
Q Y(0,0)
;
HELP(DIFRFILE) ;
N D,DIC,DIE,DIX,DIY,DO,DS,X,Y
N %,%K,%Y,DA,D0,D1,D2,D3
S DIC="^DIBT(",DIC(0)="M",DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9",X="??"
D ^DIC
Q
;
SB(DIFRDD,DIFRFLG,DIFRTA,DIFRVAL) ;Returns a list of sub-DDs for any DD#
;DD#,FLAGS,TARGET ARRAY(by value)
;DD/SUB DD NUMBER (required)
;FLAGS "W"=Include Word-processing fields (optional)
;TARGET ARRAY (required)
;DIFRVAL - SET TARGET ARRAY EQUAL TO
N DIFRSDD,DIFRSSDD,DIFRNW
S DIFRSDD=0,DIFRNW=$G(DIFRFLG)'["W",DIFRVAL=$G(DIFRVAL)
F S DIFRSDD=$O(^DD(DIFRDD,"SB",DIFRSDD)) Q:DIFRSDD'>0 D
.S DIFRSSDD=0
.I DIFRNW,$P($G(^DD(DIFRSDD,.01,0)),"^",2)["W" Q
.S @DIFRTA@(DIFRSDD)=DIFRVAL,DIFRSSDD=$O(^DD(DIFRSDD,"SB",0))
.I DIFRSSDD D SB(DIFRSDD,$G(DIFRFLG),DIFRTA,DIFRVAL)
.Q
Q
;
HDR2P(DIFRDD) ;Header Node/2nd piece update
Q:$G(DIFRDD)'>0 ""
Q:'$D(^DIC(+DIFRDD,0,"GL")) "" S DIFRDD=$TR(DIFRDD_$P($P(@(^("GL")_"0)"),"^",2),+DIFRDD,2),"DPSVIs")
N DIFRDDT
I $D(^DD(+DIFRDD,0,"ID")) S DIFRDD=DIFRDD_"I"
I $D(^DD(+DIFRDD,0,"SCR")) S DIFRDD=DIFRDD_"s"
F DIFRDDT="D","P","S","V" I $P(^DD(+DIFRDD,.01,0),"^",2)[DIFRDDT S DIFRDD=DIFRDD_DIFRDDT Q
Q DIFRDD
;
EXAM(TA) ;Examine what's in 2nd piece of data Header and put into array sub
;TA=Target Array
Q:$G(TA)']""
N FN,GR,P2
S FN=0
F S FN=$O(^DIC(FN)) Q:FN'>0 I $D(^DIC(FN,0,"GL")) S GR=^("GL") D
.Q:'$D(@(GR_"0)")) S P2=$P(^(0),"^",2),P2=$P(P2,+P2,2)
.S:P2]"" @TA@(P2)=FN
.Q
Q
;
VAL(DIFRFILE,DIFRIEN) ;Validate Edit and Print Template's and also Forms
S DIFRFILE=$G(DIFRFILE),DIFRIEN=$G(DIFRIEN)
Q:DIFRIEN'>0 0
N ROOT,PIECE,FILE
D
.N X
.S X=DIFRFILE
.I X=.4!(X=.402)!(X=.403)!(X=.404) Q
.S DIFRFILE=0
.Q
Q:DIFRFILE'>0 0
S ROOT="^"_$P($P(".4;DIPT^.402;DIE^.403;DIST(.403)^.404;DIST(.404)",DIFRFILE_";",2),"^")
S PIECE=$P($P(".4;4^.402;4^.403;8^.404;2",DIFRFILE_";",2),"^")
Q:'$D(@ROOT@(DIFRIEN,0)) 0
S FILE=$P(^(0),"^",PIECE)
I DIFRFILE=.404&('FILE) Q 1
Q:FILE'>0 0
I DIFRFILE=.403 N BLOCK D Q:'BLOCK 0
.N PAGE,BLOCKP
.S PAGE=0,BLOCK=1
.F S PAGE=$O(@ROOT@(DIFRIEN,40,PAGE)) Q:PAGE'>0 S BLOCKP=$P($G(^(PAGE,0)),"^",2) S:BLOCKP BLOCK=$$VAL(.404,BLOCKP) Q:'BLOCK D Q:'BLOCK
..N M40
..S M40=0
..F S M40=$O(@ROOT@(DIFRIEN,40,PAGE,40,M40)) Q:M40'>0 S BLOCK=$$VAL(.404,M40) Q:'BLOCK
..Q
.Q
I DIFRFILE=.4,$P(@ROOT@(DIFRIEN,0),"^",8) Q 0
Q $D(^DD(FILE,0))#2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMSS 3076 printed Apr 09, 2024@21:49:58 Page 2
DIFROMSS ;SCISC/DCL-DIFROM SERVER/DATA SORT LIST/SB-DD/HDR2P ;6/2/96 18:55
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 QUIT
SEL(DIFRFILE,DIFRX) ;Extrinsic function to return resolved value for
+1 ;freetext pointer
+2 ;FILE,X-VALUE
+3 NEW D,DIC,DIE,DIX,DIY,DO,DS,X,Y
+4 NEW %,%K,%Y,DA,D0,D1,D2,D3
+5 SET DIC="^DIBT("
SET DIC(0)="QEMZ"
SET X=DIFRX
+6 SET DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9"
+7 DO ^DIC
+8 if Y'>0
QUIT ""
+9 QUIT Y(0,0)
+10 ;
HELP(DIFRFILE) ;
+1 NEW D,DIC,DIE,DIX,DIY,DO,DS,X,Y
+2 NEW %,%K,%Y,DA,D0,D1,D2,D3
+3 SET DIC="^DIBT("
SET DIC(0)="M"
SET DIC("S")="I $P(^(0),U,4)=DIFRFILE,$D(^(1))>9"
SET X="??"
+4 DO ^DIC
+5 QUIT
+6 ;
SB(DIFRDD,DIFRFLG,DIFRTA,DIFRVAL) ;Returns a list of sub-DDs for any DD#
+1 ;DD#,FLAGS,TARGET ARRAY(by value)
+2 ;DD/SUB DD NUMBER (required)
+3 ;FLAGS "W"=Include Word-processing fields (optional)
+4 ;TARGET ARRAY (required)
+5 ;DIFRVAL - SET TARGET ARRAY EQUAL TO
+6 NEW DIFRSDD,DIFRSSDD,DIFRNW
+7 SET DIFRSDD=0
SET DIFRNW=$GET(DIFRFLG)'["W"
SET DIFRVAL=$GET(DIFRVAL)
+8 FOR
SET DIFRSDD=$ORDER(^DD(DIFRDD,"SB",DIFRSDD))
if DIFRSDD'>0
QUIT
Begin DoDot:1
+9 SET DIFRSSDD=0
+10 IF DIFRNW
IF $PIECE($GET(^DD(DIFRSDD,.01,0)),"^",2)["W"
QUIT
+11 SET @DIFRTA@(DIFRSDD)=DIFRVAL
SET DIFRSSDD=$ORDER(^DD(DIFRSDD,"SB",0))
+12 IF DIFRSSDD
DO SB(DIFRSDD,$GET(DIFRFLG),DIFRTA,DIFRVAL)
+13 QUIT
End DoDot:1
+14 QUIT
+15 ;
HDR2P(DIFRDD) ;Header Node/2nd piece update
+1 if $GET(DIFRDD)'>0
QUIT ""
+2 if '$DATA(^DIC(+DIFRDD,0,"GL"))
QUIT ""
SET DIFRDD=$TRANSLATE(DIFRDD_$PIECE($PIECE(@(^("GL")_"0)"),"^",2),+DIFRDD,2),"DPSVIs")
+3 NEW DIFRDDT
+4 IF $DATA(^DD(+DIFRDD,0,"ID"))
SET DIFRDD=DIFRDD_"I"
+5 IF $DATA(^DD(+DIFRDD,0,"SCR"))
SET DIFRDD=DIFRDD_"s"
+6 FOR DIFRDDT="D","P","S","V"
IF $PIECE(^DD(+DIFRDD,.01,0),"^",2)[DIFRDDT
SET DIFRDD=DIFRDD_DIFRDDT
QUIT
+7 QUIT DIFRDD
+8 ;
EXAM(TA) ;Examine what's in 2nd piece of data Header and put into array sub
+1 ;TA=Target Array
+2 if $GET(TA)']""
QUIT
+3 NEW FN,GR,P2
+4 SET FN=0
+5 FOR
SET FN=$ORDER(^DIC(FN))
if FN'>0
QUIT
IF $DATA(^DIC(FN,0,"GL"))
SET GR=^("GL")
Begin DoDot:1
+6 if '$DATA(@(GR_"0)"))
QUIT
SET P2=$PIECE(^(0),"^",2)
SET P2=$PIECE(P2,+P2,2)
+7 if P2]""
SET @TA@(P2)=FN
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
VAL(DIFRFILE,DIFRIEN) ;Validate Edit and Print Template's and also Forms
+1 SET DIFRFILE=$GET(DIFRFILE)
SET DIFRIEN=$GET(DIFRIEN)
+2 if DIFRIEN'>0
QUIT 0
+3 NEW ROOT,PIECE,FILE
+4 Begin DoDot:1
+5 NEW X
+6 SET X=DIFRFILE
+7 IF X=.4!(X=.402)!(X=.403)!(X=.404)
QUIT
+8 SET DIFRFILE=0
+9 QUIT
End DoDot:1
+10 if DIFRFILE'>0
QUIT 0
+11 SET ROOT="^"_$PIECE($PIECE(".4;DIPT^.402;DIE^.403;DIST(.403)^.404;DIST(.404)",DIFRFILE_";",2),"^")
+12 SET PIECE=$PIECE($PIECE(".4;4^.402;4^.403;8^.404;2",DIFRFILE_";",2),"^")
+13 if '$DATA(@ROOT@(DIFRIEN,0))
QUIT 0
+14 SET FILE=$PIECE(^(0),"^",PIECE)
+15 IF DIFRFILE=.404&('FILE)
QUIT 1
+16 if FILE'>0
QUIT 0
+17 IF DIFRFILE=.403
NEW BLOCK
Begin DoDot:1
+18 NEW PAGE,BLOCKP
+19 SET PAGE=0
SET BLOCK=1
+20 FOR
SET PAGE=$ORDER(@ROOT@(DIFRIEN,40,PAGE))
if PAGE'>0
QUIT
SET BLOCKP=$PIECE($GET(^(PAGE,0)),"^",2)
if BLOCKP
SET BLOCK=$$VAL(.404,BLOCKP)
if 'BLOCK
QUIT
Begin DoDot:2
+21 NEW M40
+22 SET M40=0
+23 FOR
SET M40=$ORDER(@ROOT@(DIFRIEN,40,PAGE,40,M40))
if M40'>0
QUIT
SET BLOCK=$$VAL(.404,M40)
if 'BLOCK
QUIT
+24 QUIT
End DoDot:2
if 'BLOCK
QUIT
+25 QUIT
End DoDot:1
if 'BLOCK
QUIT 0
+26 IF DIFRFILE=.4
IF $PIECE(@ROOT@(DIFRIEN,0),"^",8)
QUIT 0
+27 QUIT $DATA(^DD(FILE,0))#2
