- DIFROMSS ;SCISC/DCL-DIFROM SERVER/DATA SORT LIST/SB-DD/HDR2P ;6/2/96 18:55
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- DIFROMSS ;SCISC/DCL-DIFROM SERVER/DATA SORT LIST/SB-DD/HDR2P ;6/2/96 18:55
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 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
